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/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 + 168 files changed, 11360 insertions(+) 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 (limited to 'sys/imfort') 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 -- cgit