diff options
Diffstat (limited to 'sys/imio')
407 files changed, 34854 insertions, 0 deletions
diff --git a/sys/imio/README b/sys/imio/README new file mode 100644 index 00000000..2e7228bf --- /dev/null +++ b/sys/imio/README @@ -0,0 +1,210 @@ +Image i/o. Coded May 1983, D. Tody. + +This initial implementation of IMIO, described in the ".hlp" design file, +provides most of the functionality of the IMIO interface, but is not +fully optimized internally. Features include: + + (1) 7 disk datatypes (ushort, silrdx). + (2) 6 in-core datatypes (the standard silrdx). + (3) Images of up to 7 dimensions are supported internally, though + only images of up to 3 dimensions are currently supported in the + interface. + (4) Fully automatic multidimensional buffer allocation, resizing, + and deallocation. + (5) Arbitrary number of input buffers, allocated in a round robin + fashion, need not be the same size or dimension. + (5) Fully automatic type conversion. + (6) General image sections, coordinate flip, and subsampling. + (7) Both "compressed" and "block aligned" storage modes are + supported, with IMIO automatically selecting the optimal + choice during image creation. The device blocksize is a + runtime variable. + + +Planned future improvements: + + (1) Boundary extension. + (3) Optimization to the get/put line procedures to work directly + out of the FIO buffers when possible. + (3) Addition of the get/put pixel procedures. + (4) The image header is currently a simple binary file (structure). + Only one image header structure per header file is permitted. + Will be modified to use database facilities, and to permit + embedded image headers. + (5) Support for the unsigned byte disk datatype. + + +FV NOTES: I've made the following bug fixes: + +In imioff: + The setting of IM_PHYSDIM was taken outside the loop called when + IM_NDIM was zero. There is was no way to set IM_PHYSDIM in the programmer + interface. + +In imhdr.h: + The offset to the user area IMU was changed from 603 to 613. This was + a typo? + +In impnln: + The coerce statement is wrong since imgobf calls coerce to the + appropriate data type. + +In impnln: + There was a typo which did not set ve. + +------------------------ + +Review image interface. Device namining convention, use of explicit +pathnames. File read/write permissions required. Why didn't imdopen +work. + +Remove imdmap.x from system library, put in libim.a. + + +Nov 84 + Optimized line at a time i/o. Added capability to reference directly +into the FIO buffer. This greatly improved the efficiency of simple image +operations (no section, type conversion, etc.), without reducing the generality +of the interface. + + +--------------------------------------------------------------------------- +IMIO Modifications, April 1985 + + +1. Boundary Extension + + types: constant, nearest, reflect, wrap + parameters: nbndrypix, tybndry, bndrypixval + + +2. Database Access + + New fields may be added to an image with IMADD. The value of an existing +field is set with one of the IMPUT procedures; automatic type conversion will +be performed if necessary and permissible. The value of an existing field is +fetched with an IMGET procedure. The image database interface is both forward +and backward compatible, i.e., no changes are required to current programs and +the same interface (ignoring minor semantic details) will be available when +image headers are moved into DBIO. + + +Functions + + get,g - get the value of a field + put,p - set the value of a field + add,a - add a new field to a database + acc - determine if the named field exists + del - delete a field + gftype - get field datatype + gfn - get field name (matching a template) + + +Procedures + + value = imget[bcsilrdx] (im, "field") + imgstr (im, "field", outstr, maxch) + imput[bcsilrdx] (im, "field", value) + impstr (im, "field", value) + imadd[bcsilrdx] (im, "field", def_value) + imastr (im, "field", def_value) + imaddf (im, "field", "datatype") + y/n = imaccf (im, "field") + imdelf (im, "field") + type = imgftype (im, "field") + + list = imofnl[us] (im, template) + nchars/EOF = imgnfn (list, outstr, maxch) + imcfnl (list) + + +The database interface may be used to access any field of the image header, +including the following standard fields. Note that the nomenclature has +been changed slightly to make it more consistent with FITS. Additional +standard fields will be defined in the future. + + + keyword type description + + i_naxis i number of axes (dimensionality) + i_naxis[1-7] l length of an axis ("i_naxis1", etc.) + i_pixtype i pixel datatype (SPP integer code) + i_minpixval r minimum pixel value + i_maxpixval r maximum pixel value + i_ctime l time of image creation + i_mtime l time of last modify + i_limtime l time when limits (minmax) were last updated + i_title s title string + + +The following additional field names are recognized, but may disappear in the +future: + + i_history s history record (a string buffer at present) + i_pixfile s pathname of the pixel storage file + + +The names of the standard fields share an "i_" prefix to reduce the possibility +of collisions with data dependent keywords, to identify the standard fields in +sorted listings, to allow use of pattern matching to discriminate between the +standard fields and user fields, and so on. The use of the "i_" prefix is +made optional for the convenience of the interactive user, but the full name +should always be used in compiled programs. + + +3. Subfile Management (not implemented) + + A subfile B of file A is a file which is logically subordinate to A but +which is physically a separate file to the host operating system. A subfile +need not reside in the same directory as the main file. + +FIO shall provide support for subfiles as an abstract datatype. For each +ordinary file there shall optionally be zero or one subfile index files with +the same root name as the main file but with the extension .zsf. The index +file, if present, shall list the subfiles of the main file. The operations +supported by FIO for subfiles shall include the following: + + + add a subfile to index and return pathname + delete a subfile from index and return pathname + get the pathname of a subfile + delete both index entry and physical file + delete a file and all subfiles + + +It is important that FIO maintain the mapping of a subfile name to a physical +file name to permit moves, copies, renames, etc. of files and their subfiles. +Having to open the index file to get the pathname of a subfile is however +inefficient. To achieve both flexibility and efficiency the system packages +IMIO and DBIO will cache the names of subfiles to eliminate most accesses to +the index files. + + + add a subfile: + add subfile to the index + cache pathname + + open subfile: + repeat { + open subfile using cached pathname + if (file cannot be opened) { + call fio to get the pathname of the subfile + if (different from cached pathname) { + update cached pathname + next + } else + error: cannot open file + } else { + read file header and verify that this is our subfile + if (not our subfile) { + close file + call fio to get the pathname of the subfile + if (different from cached pathname) { + update cached pathname + next + } else + error: not our subfile + } else + break # success + } + } diff --git a/sys/imio/db/README b/sys/imio/db/README new file mode 100644 index 00000000..cf7f9c1c --- /dev/null +++ b/sys/imio/db/README @@ -0,0 +1,105 @@ + Image Header Database Interface + dct 16-Apr-85 + +1. Overview + + This directory contains the first version of the image header database +interface. In this implementation the image header is a variable length fixed +format binary structure. The first, fixed format, part of the image header +contains the standard fields in binary and is fixed in size. This is followed +by the so called "user area", a string buffer containing a sequence of +variable length, newline delimited FITS format keyword=value header cards. +When an image is open a large user area is allocated to permit the addition +of new parameters without filling up the buffer. When the header is +subsequently updated on disk only as much disk space is used as is needed to +store the actual header. + +This format header is upwards compatible with the old image header format, +hence old images and programs do not have to be modified to use the IMIO +release supporting database accesss. In the future image headers will be +maintained under DBIO, but the routines in the image header database interface +are not exected to change. The actual disk format of images will of course +change when we switch over to the DBIO headers. + + + +2. Functions + + get,g - get the value of a field + put,p - set the value of a field + add,a - add a new field to a database + acc - determine if the named field exists + + +3. Procedures + + value = imget[bcsilrdx] (im, "field") + imgstr (im, "field", outstr, maxch) + imput[bcsilrdx] (im, "field", value) + impstr (im, "field", value) + imadd[bcsilrdx] (im, "field", def_value) + imastr (im, "field", def_value) + imaddf (im, "field", "datatype") + y/n = imaccf (im, "field") + + list = imofnl[su] (im, template) + nch = imgnfn (im, outstr, maxch) + imcfnl (im) + + + +4. Description + + New parameters will typically be added to the image header with either +one of the typed procedures IMADD_ or with the lower level procedure IMADDF. +The former procedures permit the parameter to be created and the value +initialized all in one call, while the latter only creates the parameter. +In addition, the typed IMADD_ procedures may be used to update the values +of existing parameters (it is not considered an error if the parameter +already exists). The principal limitation of the typed procedures is that +they may only be used to add or set parameters of a standard datatype. +The IMADDF procedure will permit creation of parameters with more descriptive +datatypes (domains) when the interface is recut upon DBIO. + +The value of any parameter may be fetched with one of the IMGET functions. +The IMACCF function may be used (like ACCESS for a file) to determine +whether a parameter exists. + +The database interface may be used to access any field of the image header, +including the following standard fields. Note that the nomenclature has +been changed slightly to make it more consistent with FITS. Additional +standard fields will be defined in the future. + + + keyword type description + + i_naxis i number of axes (dimensionality) + i_naxis[1-7] l length of an axis ("i_naxis1", etc.) + i_pixtype i pixel datatype (SPP integer code) + i_minpixval r minimum pixel value + i_maxpixval r maximum pixel value + i_ctime l time of image creation + i_mtime l time of last modify + i_limtime l time when limits (minmax) were last updated + i_title s title string + + +The names of the standard fields share an "i_" prefix to reduce the possibility +of collisions with data dependent keywords, to identify the standard fields in +sorted listings, to allow use of pattern matching to discriminate between the +standard fields and user fields, and so on. For the convenience of the user, +the "i_" prefix may be omitted provided the resultant name does not match the +name of a user parameter. It is however recommended that the full name be +used in all applications software. + + +5. Restrictions + + The use of FITS format as the internal format for storing fields in this +version of the interface places restrictions on the size of field names and +of the string value of string valued parameters. Field names are currently +limited to eight characters or less and case is ignored (since FITS requires +upper case). The eight character limit does not apply to the standard fields. +String values are limited to at most 68 characters. If put string is passed +a longer string it will be silently truncated. Trailing whitespace and +newlines are chopped when a string value is read. diff --git a/sys/imio/db/idb.h b/sys/imio/db/idb.h new file mode 100644 index 00000000..327ce3d2 --- /dev/null +++ b/sys/imio/db/idb.h @@ -0,0 +1,24 @@ +# IDB.H -- Image header database interface. In this version of the interface +# the standard image header fields are maintained in binary in a fixed +# structure and the user fields are maintained in FITS format (text) in the +# a string buffer following the binary image header. + +define IDB_RECLEN 80 # length of a FITS record (card) +define IDB_STARTVALUE 10 # first column of value field +define IDB_ENDVALUE 30 # last column of value field +define IDB_LENNUMERICRECORD 80 # length of new numeric records +define IDB_LENSTRINGRECORD 80 # length of new string records +define IDB_SZFITSKEY 8 # max length FITS keyword + +# Standard header keywords accessible via the database interface. + +define I_CTIME 1 +define I_HISTORY 2 +define I_LIMTIME 3 +define I_MAXPIXVAL 4 +define I_MINPIXVAL 5 +define I_MTIME 6 +define I_NAXIS 7 +define I_PIXFILE 8 +define I_PIXTYPE 9 +define I_TITLE 10 diff --git a/sys/imio/db/idbcard.x b/sys/imio/db/idbcard.x new file mode 100644 index 00000000..38ea36fb --- /dev/null +++ b/sys/imio/db/idbcard.x @@ -0,0 +1,134 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> +include "idb.h" + +.help IDBCARD +.nf ------------------------------------------------------------------------- +Card i/o package, for reading through the FITS area of the image header. + + idb = idb_open (im, ualen) + recno|EOF = idb_nextcard (idb, rp) + idb_close (idb) + +This is a very simple package, used only to hide the details of how to +access successive image header cards. The main routine returns a char +pointer to successive cards until the end of the header is reached. +This is convenient for efficient read access to the header; direct i/o +to the image header may be accomplished by using STROPEN to open the +header buffer on a file descriptor. + +This entire interface assumes that the header is stored in FITS format, +which is an implementation detail of the current IMIO interface. Hence, +this interface is internal to IMIO. +.endhelp -------------------------------------------------------------------- + +define LEN_IDB 6 +define IDB_IM Memi[$1] # image descriptor +define IDB_UA Memi[$1+1] # pointer to user area +define IDB_UALEN Memi[$1+2] # length of user area +define IDB_RECPTR Memi[$1+3] # current record pointer +define IDB_RECNO Memi[$1+4] # current record number +define IDB_BLOCKED Memi[$1+5] # cards blank filled? + + +# IDB_OPEN -- Open the FITS area for for card i/o. + +pointer procedure idb_open (im, ualen) + +pointer im #I image descriptor +int ualen #O size of storage area + +int n +pointer idb, ip +errchk malloc + +begin + call malloc (idb, LEN_IDB, TY_STRUCT) + + IDB_IM(idb) = im + IDB_UA(idb) = IM_USERAREA(im) + IDB_UALEN(idb) = (LEN_IMDES + IM_LENHDRMEM(im) - IMU) * SZ_STRUCT - 1 + IDB_RECPTR(idb) = IM_USERAREA(im) + IDB_RECNO(idb) = 1 + + if (IM_UABLOCKED(im) < 0) { + # At image open time this flag is set by IMMAP to -1 to indicate + # that the user area record type is not known. An IKI kernel may + # subsequently set the flag to yes/no, else we determine the + # record type by inspection the first time we are called. If the + # user area is empty the record type is set to blocked; IDB always + # writes blocked records. + + IM_UABLOCKED(im) = YES + for (ip=IM_USERAREA(im); Memc[ip] != EOS; ip=ip+1) { + for (n=0; Memc[ip] != EOS; n=n+1) { + if (Memc[ip] == '\n') + break + ip = ip + 1 + } + if (n != IDB_RECLEN) { + IM_UABLOCKED(im) = NO + break + } + } + } + + IDB_BLOCKED(idb) = IM_UABLOCKED(im) + ualen = IDB_UALEN(idb) + return (idb) +end + + +# IDB_NEXTCARD -- Return a pointer to the next card in the FITS header. +# EOF is returned at the end of the header. + +int procedure idb_nextcard (idb, recptr) + +pointer idb #I pointer to IDB descriptor +pointer recptr #O pointer to card + +int recno +pointer ip, i + +begin + # Reference current card. + recno = IDB_RECNO(idb) + recptr = IDB_RECPTR(idb) + + # Advance to the next card. + ip = recptr + if (IDB_BLOCKED(idb) == NO) { + if (Memc[ip] != EOS) # skip blank lines + ip = ip + 1 + do i = ip, ip+IDB_RECLEN + if (Memc[i] == EOS) { + ip = i + break + } else if (Memc[i] == '\n') { + ip = i + 1 + break + } + } else + ip = ip + IDB_RECLEN + 1 + + IDB_RECNO(idb) = recno + 1 + IDB_RECPTR(idb) = ip + + if (Memc[recptr] == EOS || recptr >= IDB_UA(idb) + IDB_UALEN(idb)) + return (EOF) + else + return (recno) +end + + +# IDB_CLOSE -- Free the IDB descriptor. + +procedure idb_close (idb) + +pointer idb #I pointer to IDB descriptor + +begin + call mfree (idb, TY_STRUCT) +end diff --git a/sys/imio/db/idbfind.x b/sys/imio/db/idbfind.x new file mode 100644 index 00000000..f98acb7e --- /dev/null +++ b/sys/imio/db/idbfind.x @@ -0,0 +1,145 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.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, n, i +int patmake(), patmatch(), stridxs(), gstrcpy() + +begin + call smark (sp) + call salloc (pat, SZ_FNAME, TY_CHAR) + call salloc (ukey, SZ_FNAME, TY_CHAR) + call salloc (lkey, SZ_FNAME, TY_CHAR) + call salloc (patbuf, SZ_LINE, TY_CHAR) + + # Prepare U/L FITS keywords, truncated to 8 chars. + nchars = gstrcpy (key, Memc[lkey], IDB_SZFITSKEY) + call strlwr (Memc[lkey]) + nchars = gstrcpy (key, Memc[ukey], IDB_SZFITSKEY) + call strupr (Memc[ukey]) + + # Search for the FIRST occurrence of a record with the given key. + # If the key is abbreviated and multiple keys are matched, the first + # record matched is used. + + ua = IM_USERAREA(im) + rp = NULL + recno = 1 + + if (IM_UABLOCKED(im) < 0) { + # At image open time this flag is set by IMMAP to -1 to indicate + # that the user area record type is not known. An IKI kernel may + # subsequently set the flag to yes/no, else we determine the + # record type by inspection the first time we are called. If the + # user area is empty the record type is set to blocked; IDB always + # writes blocked records. + + IM_UABLOCKED(im) = YES + for (ip=ua; Memc[ip] != EOS; ip=ip+1) { + for (n=0; Memc[ip] != EOS; n=n+1) { + if (Memc[ip] == '\n') + break + ip = ip + 1 + } + if (n != IDB_RECLEN) { + IM_UABLOCKED(im) = NO + break + } + } + } + + if (IM_UABLOCKED(im) == NO) { + # Variable length, newline terminated records, EOS terminated + # record group. + + call sprintf (Memc[pat], SZ_FNAME, "^{%s}[ =]") + call pargstr (Memc[ukey]) + junk = patmake (Memc[pat], Memc[patbuf], SZ_LINE) + + for (ip=ua; Memc[ip] != EOS; ip=ip+1) { + if (patmatch (Memc[ip], Memc[patbuf]) > 0) { + rp = ip + break + } + #if (Memc[ip] != EOS) + # ip = ip + 1 + while (Memc[ip] != '\n' && Memc[ip] != EOS) + ip = ip + 1 + recno = recno + 1 + } + + } else { + # Fixed length (80 character), newline terminated records, EOS + # terminated record group. + + if (stridxs ("*?[]", Memc[ukey]) > 0) { + # Pattern matching search. + call sprintf (Memc[pat], SZ_FNAME, "^{%s}[ =]") + call pargstr (Memc[ukey]) + junk = patmake (Memc[pat], Memc[patbuf], SZ_LINE) + + for (ip=ua; Memc[ip] != EOS; ip=ip+IDB_RECLEN+1) { + if (patmatch (Memc[ip], Memc[patbuf]) > 0) { + rp = ip + break + } + recno = recno + 1 + } + + } else { + # Simple fast search, fixed length records. Case insensitive + # keyword match. + + lch = Memc[lkey] + uch = Memc[ukey] + + for (ip=ua; Memc[ip] != EOS; ip=ip+IDB_RECLEN+1) { + ch = Memc[ip] + if (ch == EOS) + break + else if (ch != lch && ch != uch) + next + else { + # Abbreviations are not permitted. + ch = Memc[ip+nchars] + if (ch != ' ' && ch != '=') + next + } + + # First char matches; check rest of string. + do i = 1, nchars-1 { + ch = Memc[ip+i] + if (ch != Memc[lkey+i] && ch != Memc[ukey+i]) { + ch = 0 + break + } + } + if (ch != 0) { + rp = ip # match + break + } + + recno = recno + 1 + } + } + } + + call sfree (sp) + if (rp == NULL) + return (0) + else + return (recno) +end diff --git a/sys/imio/db/idbfstr.x b/sys/imio/db/idbfstr.x new file mode 100644 index 00000000..1087ca02 --- /dev/null +++ b/sys/imio/db/idbfstr.x @@ -0,0 +1,40 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <ctype.h> + + +# IDB_FILSTR -- Filter a string, removing any tabs or control characters. +# This is used to clean up strings we want to put in image headers. A count +# of the output, filtered string is returned as the function value. Tabs or +# newlines in the input are replaced by blanks. Illegal or unprintable +# control characters in the input are deleted. + +int procedure idb_filstr (s1, s2, maxch) + +char s1[ARB] #I input string +char s2[ARB] #O output string +int maxch #I max chars out + +int op, ch, i + +begin + op = 1 + + do i = 1, ARB { + ch = s1[i] + if (ch == EOS) + break + else if (ch == '\t' || ch == '\n') + ch = ' ' + else if (!IS_PRINT (ch)) + next + + s2[op] = ch + op = op + 1 + if (op > maxch) + break + } + + s2[op] = EOS + return (op - 1) +end diff --git a/sys/imio/db/idbgstr.x b/sys/imio/db/idbgstr.x new file mode 100644 index 00000000..ffa43ff9 --- /dev/null +++ b/sys/imio/db/idbgstr.x @@ -0,0 +1,85 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <ctype.h> +include <imhdr.h> +include "idb.h" + +define TY_STRING (-1) + +# IDB_GETSTRING -- Get the string value of a standard header parameter. If the +# actual type of the parameter is not string the value is encoded as a string. +# The length of the string is returned as the function value. ERR is returned +# if the string cannot be found. + +int procedure idb_getstring (im, key, outstr, maxch) + +pointer im # image descriptor +char key[ARB] # parameter to be returned +char outstr[ARB] # output string to receive parameter value +int maxch + +long lval +real rval +int dtype, axis, ip +int gstrcpy(), idb_kwlookup(), strncmp(), ltoc(), strlen() +define encode_ 91 + +begin + # A standard keyword is recognized with or without the "i_" prefix. + if (key[1] == 'i' && key[2] == '_') + ip = 3 + else + ip = 1 + + # The keywords "naxis1", "naxis2", etc. are treated as a special case. + if (strncmp (key[ip], "naxis", 5) == 0) + if (IS_DIGIT(key[ip+5]) && key[ip+6] == EOS) { + dtype = TY_LONG + axis = TO_INTEG(key[ip+5]) + lval = IM_LEN(im,axis) + goto encode_ + } + + switch (idb_kwlookup (key[ip])) { + case I_CTIME: + dtype = TY_LONG + lval = IM_CTIME(im) + case I_HISTORY: + dtype = TY_STRING + return (gstrcpy (IM_HISTORY(im), outstr, maxch)) + case I_LIMTIME: + dtype = TY_LONG + lval = IM_LIMTIME(im) + case I_MAXPIXVAL: + dtype = TY_REAL + rval = IM_MAX(im) + case I_MINPIXVAL: + dtype = TY_REAL + rval = IM_MIN(im) + case I_MTIME: + dtype = TY_LONG + lval = IM_MTIME(im) + case I_NAXIS: + dtype = TY_LONG + lval = IM_NDIM(im) + case I_PIXFILE: + return (gstrcpy (IM_PIXFILE(im), outstr, maxch)) + case I_PIXTYPE: + dtype = TY_LONG + lval = IM_PIXTYPE(im) + case I_TITLE: + return (gstrcpy (IM_TITLE(im), outstr, maxch)) + default: + outstr[1] = EOS + return (ERR) + } + +encode_ + if (dtype == TY_LONG) + return (ltoc (lval, outstr, maxch)) + else { + call sprintf (outstr, maxch, "%g") + call pargr (rval) + return (strlen (outstr)) + } +end diff --git a/sys/imio/db/idbkwlu.x b/sys/imio/db/idbkwlu.x new file mode 100644 index 00000000..5b3ee553 --- /dev/null +++ b/sys/imio/db/idbkwlu.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <ctype.h> +include <imhdr.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|history|limtime|maxpixval|minpixval|mtime|naxis\ +|pixfile|pixtype|title|" + +begin + call smark (sp) + call salloc (kwname, SZ_FNAME, TY_CHAR) + + # Look the string up in the dictionary of standard keywords. Note that + # the "i_" prefix is omitted in the dictionary. The order of the + # keywords in the dictionary must agree with the defined codes in the + # header file. A standard keyword is recognized with or without the + # "i_" prefix. + + if (key[1] == 'i' && key[2] == '_') + ip = 3 + else + ip = 1 + + # Check for a reference to one of the NAXIS keywords. + if (key[ip] == 'n') + if (strncmp (key[ip], "naxis", 5) == 0) { + ch = key[ip+5] + if (ch == EOS || (IS_DIGIT(ch) && key[ip+6] == EOS)) { + call sfree (sp) + return (7) + } + } + + # Look up keyword in dictionary. Abbreviations are not permitted. + index = strdic (key[ip], Memc[kwname], SZ_FNAME, keywords) + if (index != 0) + if (strlen(key[ip]) != strlen(Memc[kwname])) + index = 0 + + call sfree (sp) + return (index) +end diff --git a/sys/imio/db/idbpstr.x b/sys/imio/db/idbpstr.x new file mode 100644 index 00000000..e2facd75 --- /dev/null +++ b/sys/imio/db/idbpstr.x @@ -0,0 +1,101 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <mach.h> +include <ctype.h> +include <imhdr.h> +include "idb.h" + +# IDB_PUTSTRING -- Set the value of a standard header parameter given the new +# value of the parameter encoded as a string. If actual type of the parameter +# is non string the value must be decoded. ERR is returned if the key is not +# a standard header parameter. An error action is taken if the key is known +# but the value cannot be decoded. + +int procedure idb_putstring (im, key, strval) + +pointer im # image descriptor +char key[ARB] # parameter to be returned +char strval[ARB] # string value of parameter + +double dval +bool numeric +int ip, axis +int strncmp(), gstrcpy(), idb_kwlookup(), ctod(), strlen() + +begin + # Determine if the given string value is numeric. This is true if + # it consists of a single numeric token of a reasonable length. + + ip = 1 + numeric = false + if (strlen (strval) < MAX_DIGITS) + if (ctod (strval, ip, dval) > 0) { + while (IS_WHITE (strval[ip]) || strval[ip] == '\n') + ip = ip + 1 + numeric = (strval[ip] == EOS) + } + + # A standard keyword is recognized with or without the "i_" prefix. + if (key[1] == 'i' && key[2] == '_') + ip = 3 + else + ip = 1 + + # The keywords "naxis1", "naxis2", etc. are treated as a special case. + if (strncmp (key[ip], "naxis", 5) == 0) + if (IS_DIGIT(key[ip+5]) && key[ip+6] == EOS) { + axis = TO_INTEG(key[ip+5]) + if (numeric && axis >= 1 && axis <= IM_NDIM(im)) { + IM_LEN(im,axis) = nint(dval) + return (OK) + } else + call syserrs (SYS_IDBTYPE, key) + } + + # Lookup the keyword in the dictionary and set the value of the + # header parameter. If the parameter is string valued copy the + # string value and return immediately. + + switch (idb_kwlookup (key[ip])) { + case I_CTIME: + if (numeric) + IM_CTIME(im) = nint(dval) + case I_HISTORY: + return (gstrcpy (strval, IM_HISTORY(im), SZ_IMHIST)) + case I_LIMTIME: + if (numeric) + IM_LIMTIME(im) = nint(dval) + case I_MAXPIXVAL: + if (numeric) + IM_MAX(im) = dval + case I_MINPIXVAL: + if (numeric) + IM_MIN(im) = dval + case I_MTIME: + if (numeric) + IM_MTIME(im) = nint(dval) + case I_NAXIS: + if (numeric) + IM_NDIM(im) = nint(dval) + case I_PIXFILE: + return (gstrcpy (strval, IM_PIXFILE(im), SZ_IMPIXFILE)) + case I_PIXTYPE: + if (numeric) + IM_PIXTYPE(im) = nint(dval) + case I_TITLE: + return (gstrcpy (strval, IM_TITLE(im), SZ_IMTITLE)) + default: + return (ERR) + } + + # If we make it through the switch, i.e., do not execute a return + # statement, then the key was recognized and is of a numeric datatype. + # If the value was successfully decoded as numeric then all is well, + # else the value could not be decoded and we have an error. + + if (!numeric) + call syserrs (SYS_IDBTYPE, key) + else + return (OK) +end diff --git a/sys/imio/db/imaccf.x b/sys/imio/db/imaccf.x new file mode 100644 index 00000000..60e4e9f3 --- /dev/null +++ b/sys/imio/db/imaccf.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMACCF -- Test if the named field exists. NO is returned if the key is not +# found, YES otherwise. + +int procedure imaccf (im, key) + +pointer im # image descriptor +char key[ARB] # name of the new parameter +int idb_kwlookup(), idb_findrecord() +pointer rp + +begin + if ((idb_kwlookup (key) > 0) || (idb_findrecord (im, key, rp) > 0)) + return (YES) + else + return (NO) +end diff --git a/sys/imio/db/imaddb.x b/sys/imio/db/imaddb.x new file mode 100644 index 00000000..f60f435a --- /dev/null +++ b/sys/imio/db/imaddb.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMADDB -- Add a new field to the image header and initialize to the value +# given. It is not an error if the parameter already exists. + +procedure imaddb (im, key, value) + +pointer im # image descriptor +char key[ARB] # parameter or field value +bool value # new or initial value of parameter + +int imaccf() +errchk imaccf, imaddf + +begin + if (imaccf (im, key) == NO) + call imaddf (im, key, "b") + call imputb (im, key, value) +end diff --git a/sys/imio/db/imaddd.x b/sys/imio/db/imaddd.x new file mode 100644 index 00000000..f5811b79 --- /dev/null +++ b/sys/imio/db/imaddd.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMADDD -- Add a new field to the image header and initialize to the value +# given. It is not an error if the parameter already exists. + +procedure imaddd (im, key, value) + +pointer im # image descriptor +char key[ARB] # parameter or field value +double value # new or initial value of parameter + +int imaccf() +errchk imaccf, imaddf + +begin + if (imaccf (im, key) == NO) + call imaddf (im, key, "d") + call imputd (im, key, value) +end diff --git a/sys/imio/db/imaddf.x b/sys/imio/db/imaddf.x new file mode 100644 index 00000000..e2328f78 --- /dev/null +++ b/sys/imio/db/imaddf.x @@ -0,0 +1,96 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <fset.h> +include <imhdr.h> +include <imio.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) + +pointer im #I image descriptor +char key[ARB] #I name of the new parameter +char datatype[ARB] #I string permits generalization to domains + +pointer rp, sp, keyname, ua, ip +int fd, max_lenuserarea, curlen, buflen, nchars +int idb_kwlookup(), idb_findrecord() +int stropen(), strlen(), idb_filstr(), nowhite() +errchk syserrs, stropen, fprintf, pargstr, pargi + +begin + call smark (sp) + call salloc (keyname, SZ_FNAME, TY_CHAR) + + # FITS format requires that the keyword name be upper case, not to + # exceed 8 characters in length. [Nov97 - This is not entirely + # correct, FITS does not require upper case, however we don't want + # to change this at this time.] + + nchars = idb_filstr (key, Memc[keyname], IDB_SZFITSKEY) + nchars = nowhite (Memc[keyname], Memc[keyname], IDB_SZFITSKEY) + call strupr (Memc[keyname]) + + # Check for a redefinition. + if ((idb_kwlookup (key) > 0) || (idb_findrecord (im, key, rp) > 0)) + call syserrs (SYS_IDBREDEF, key) + + # Open the user area string for appending. 'buflen' is the malloc-ed + # buffer length in struct units; IMU is the struct offset to the user + # area, i.e., the size of that part of the image descriptor preceding + # the user area. If the buffer fills we must allow one extra char for + # the EOS delimiter; since storage for the image descriptor was + # allocated in struct units the storage allocator will not have + # allocated space for the extra EOS char. + + ua = IM_USERAREA(im) + curlen = strlen (Memc[ua]) + buflen = LEN_IMDES + IM_LENHDRMEM(im) + max_lenuserarea = (buflen - IMU) * SZ_STRUCT - 1 + + # If the user area is not empty the last character must be the newline + # record delimiter, else the new record we add will be invalid. + + if (curlen > 0 && Memc[ua+curlen-1] != '\n') + if (curlen >= max_lenuserarea) + call syserrs (SYS_IDBOVFL, key) + else { + Memc[ua+curlen] = '\n' + curlen = curlen + 1 + Memc[ua+curlen] = EOS + } + + fd = stropen (Memc[ua+curlen], max_lenuserarea-curlen, APPEND) + + # Append the new record with an uninitialized value field. + iferr { + call fprintf (fd, "%-8s= %s%*t\n") + call pargstr (Memc[keyname]) + if (datatype[1] == 'c') { + call pargstr ("' '") + call pargi (IDB_LENSTRINGRECORD + 1) + } else { + call pargstr ("") + call pargi (IDB_LENNUMERICRECORD + 1) + } + + } then { + # Out of space in the user area. Discard the truncated card at the + # end of the buffer by backing up to the last newline and writing + # an EOS. + + call close (fd) + for (ip=ua+max_lenuserarea-1; ip > ua; ip=ip-1) + if (Memc[ip] == '\n') { + Memc[ip+1] = EOS + break + } + call syserrs (SYS_IDBOVFL, key) + } + + call close (fd) + call sfree (sp) +end diff --git a/sys/imio/db/imaddi.x b/sys/imio/db/imaddi.x new file mode 100644 index 00000000..76653e66 --- /dev/null +++ b/sys/imio/db/imaddi.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMADDI -- Add a new field to the image header and initialize to the value +# given. It is not an error if the parameter already exists. + +procedure imaddi (im, key, value) + +pointer im # image descriptor +char key[ARB] # parameter or field value +int value # new or initial value of parameter + +int imaccf() +errchk imaccf, imaddf + +begin + if (imaccf (im, key) == NO) + call imaddf (im, key, "i") + call imputi (im, key, value) +end diff --git a/sys/imio/db/imaddl.x b/sys/imio/db/imaddl.x new file mode 100644 index 00000000..9064f6c4 --- /dev/null +++ b/sys/imio/db/imaddl.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMADDL -- Add a new field to the image header and initialize to the value +# given. It is not an error if the parameter already exists. + +procedure imaddl (im, key, value) + +pointer im # image descriptor +char key[ARB] # parameter or field value +long value # new or initial value of parameter + +int imaccf() +errchk imaccf, imaddf + +begin + if (imaccf (im, key) == NO) + call imaddf (im, key, "l") + call imputl (im, key, value) +end diff --git a/sys/imio/db/imaddr.x b/sys/imio/db/imaddr.x new file mode 100644 index 00000000..e07dbb53 --- /dev/null +++ b/sys/imio/db/imaddr.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMADDR -- Add a new field to the image header and initialize to the value +# given. It is not an error if the parameter already exists. + +procedure imaddr (im, key, value) + +pointer im # image descriptor +char key[ARB] # parameter or field value +real value # new or initial value of parameter + +int imaccf() +errchk imaccf, imaddf + +begin + if (imaccf (im, key) == NO) + call imaddf (im, key, "r") + call imputr (im, key, value) +end diff --git a/sys/imio/db/imadds.x b/sys/imio/db/imadds.x new file mode 100644 index 00000000..e1b9f1a1 --- /dev/null +++ b/sys/imio/db/imadds.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMADDS -- Add a new field to the image header and initialize to the value +# given. It is not an error if the parameter already exists. + +procedure imadds (im, key, value) + +pointer im # image descriptor +char key[ARB] # parameter or field value +short value # new or initial value of parameter + +int imaccf() +errchk imaccf, imaddf + +begin + if (imaccf (im, key) == NO) + call imaddf (im, key, "s") + call imputs (im, key, value) +end diff --git a/sys/imio/db/imastr.x b/sys/imio/db/imastr.x new file mode 100644 index 00000000..d87c1828 --- /dev/null +++ b/sys/imio/db/imastr.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMASTR -- Add a new field to the image header and initialize to the value +# given. It is not an error if the parameter already exists. + +procedure imastr (im, key, value) + +pointer im # image descriptor +char key[ARB] # parameter or field value +char value[ARB] # new or initial value of parameter + +int imaccf() +errchk imaccf, imaddf + +begin + if (imaccf (im, key) == NO) + call imaddf (im, key, "c") + call impstr (im, key, value) +end diff --git a/sys/imio/db/imdelf.x b/sys/imio/db/imdelf.x new file mode 100644 index 00000000..e8365e22 --- /dev/null +++ b/sys/imio/db/imdelf.x @@ -0,0 +1,44 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include "idb.h" + +# IMDELF -- Delete a user field from the image header. It is an error if the +# named field does not exist. + +procedure imdelf (im, key) + +pointer im # image descriptor +char key[ARB] # name of the new parameter + +int off +pointer rp, sp, keyname +int idb_kwlookup(), idb_findrecord(), stridxs() +errchk syserrs + +begin + call smark (sp) + call salloc (keyname, SZ_FNAME, TY_CHAR) + + # FITS format requires that the keyword name be upper case. + call strcpy (key, Memc[keyname], IDB_SZFITSKEY) + call strupr (Memc[keyname]) + + # Cannot delete standard header keywords. + if (idb_kwlookup (key) > 0) + call syserrs (SYS_IDBNODEL, key) + + # Verify that the named user field exists. + if (idb_findrecord (im, key, rp) <= 0) + call syserrs (SYS_IDBDELNXKW, key) + + # Delete the field. + off = stridxs ("\n", Memc[rp]) + if (off > 0) + call strcpy (Memc[rp+off], Memc[rp], ARB) + else + Memc[rp] = EOS + + call sfree (sp) +end diff --git a/sys/imio/db/imgetb.x b/sys/imio/db/imgetb.x new file mode 100644 index 00000000..cd7ed03f --- /dev/null +++ b/sys/imio/db/imgetb.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include "idb.h" + +# IMGETB -- Get an image header parameter of type boolean. False is returned +# if the parameter cannot be found or if the value is not true. + +bool procedure imgetb (im, key) + +pointer im # image descriptor +char key[ARB] # parameter to be returned + +pointer rp +pointer idb_findrecord() + +begin + if (idb_findrecord (im, key, rp) == 0) + call syserrs (SYS_IDBKEYNF, key) + else + return (Memc[rp+IDB_ENDVALUE-1] == 'T') +end diff --git a/sys/imio/db/imgetc.x b/sys/imio/db/imgetc.x new file mode 100644 index 00000000..f56ecb9d --- /dev/null +++ b/sys/imio/db/imgetc.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMGETC -- Get an image header parameter of type char. + +char procedure imgetc (im, key) + +pointer im # image descriptor +char key[ARB] # parameter to be returned +long imgetl() + +begin + return (imgetl (im, key)) +end diff --git a/sys/imio/db/imgetd.x b/sys/imio/db/imgetd.x new file mode 100644 index 00000000..01a71cb1 --- /dev/null +++ b/sys/imio/db/imgetd.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include "idb.h" + +# IMGETD -- Get an image header parameter of type double floating. If the +# named parameter is a standard parameter return the value directly, +# else scan the user area for the named parameter and decode the value. + +double procedure imgetd (im, key) + +pointer im # image descriptor +char key[ARB] # parameter to be returned + +int ip +double dval +pointer sp, sval +int ctod() +errchk syserrs, imgstr + +begin + call smark (sp) + call salloc (sval, SZ_LINE, TY_CHAR) + + ip = 1 + call imgstr (im, key, Memc[sval], SZ_LINE) + if (ctod (Memc[sval], ip, dval) == 0) + call syserrs (SYS_IDBTYPE, key) + + call sfree (sp) + return (dval) +end diff --git a/sys/imio/db/imgeti.x b/sys/imio/db/imgeti.x new file mode 100644 index 00000000..8da2878e --- /dev/null +++ b/sys/imio/db/imgeti.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMGETI -- Get an image header parameter of type integer. + +int procedure imgeti (im, key) + +pointer im # image descriptor +char key[ARB] # parameter to be returned + +long lval, imgetl() +errchk imgetl + +begin + lval = imgetl (im, key) + if (IS_INDEFL(lval)) + return (INDEFI) + else + return (lval) +end diff --git a/sys/imio/db/imgetl.x b/sys/imio/db/imgetl.x new file mode 100644 index 00000000..817715c0 --- /dev/null +++ b/sys/imio/db/imgetl.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMGETL -- Get an image header parameter of type long integer. + +long procedure imgetl (im, key) + +pointer im # image descriptor +char key[ARB] # parameter to be returned + +double dval, imgetd() +errchk imgetd + +begin + dval = imgetd (im, key) + if (IS_INDEFD(dval)) + return (INDEFL) + else + return (nint (dval)) +end diff --git a/sys/imio/db/imgetr.x b/sys/imio/db/imgetr.x new file mode 100644 index 00000000..b1c6c67a --- /dev/null +++ b/sys/imio/db/imgetr.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMGETR -- Get an image header parameter of type real. + +real procedure imgetr (im, key) + +pointer im # image descriptor +char key[ARB] # parameter to be returned + +double dval, imgetd() +errchk imgetd + +begin + dval = imgetd (im, key) + if (IS_INDEFD(dval)) + return (INDEFR) + else + return (dval) +end diff --git a/sys/imio/db/imgets.x b/sys/imio/db/imgets.x new file mode 100644 index 00000000..39f2fcfd --- /dev/null +++ b/sys/imio/db/imgets.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMGETS -- Get an image header parameter of type short integer. + +short procedure imgets (im, key) + +pointer im # image descriptor +char key[ARB] # parameter to be returned + +long lval, imgetl() +errchk imgetl + +begin + lval = imgetl (im, key) + if (IS_INDEFL(lval)) + return (INDEFS) + else + return (lval) +end diff --git a/sys/imio/db/imgftype.x b/sys/imio/db/imgftype.x new file mode 100644 index 00000000..12ee9048 --- /dev/null +++ b/sys/imio/db/imgftype.x @@ -0,0 +1,71 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <ctype.h> +include "idb.h" + +# IMGFTYPE -- Get the datatype of a particular field of an image header. Since +# the internal format is FITS, there are four primary datatypes, boolean (T|F), +# string (quoted), integer and real. + +int procedure imgftype (im, key) + +pointer im # image descriptor +char key[ARB] # parameter to be set + +pointer rp +int ch, ip +int idb_findrecord(), idb_kwlookup() +errchk syserrs + +begin + # Check for a standard header keyword. + switch (idb_kwlookup (key)) { + case I_CTIME: + return (TY_LONG) + case I_HISTORY: + return (TY_CHAR) + case I_LIMTIME: + return (TY_LONG) + case I_MAXPIXVAL: + return (TY_REAL) + case I_MINPIXVAL: + return (TY_REAL) + case I_MTIME: + return (TY_LONG) + case I_NAXIS: + return (TY_LONG) + case I_PIXFILE: + return (TY_CHAR) + case I_PIXTYPE: + return (TY_LONG) + case I_TITLE: + return (TY_CHAR) + } + + # If we get here then the named parameter is not a standard header + # keyword. + + if (idb_findrecord (im, key, rp) > 0) { + # Check for quoted string. + ch = Memc[rp+IDB_STARTVALUE] + if (ch == '\'') + return (TY_CHAR) + + # Check for boolean field. + ch = Memc[rp+IDB_ENDVALUE-1] + if (ch == 'T' || ch == 'F') + return (TY_BOOL) + + # If field contains only digits it must be an integer. + for (ip=IDB_STARTVALUE; ip <= IDB_ENDVALUE; ip=ip+1) { + ch = Memc[rp+ip-1] + if (! (IS_DIGIT(ch) || IS_WHITE(ch))) + return (TY_REAL) + } + + return (TY_INT) + } + + call syserrs (SYS_IDBKEYNF, key) +end diff --git a/sys/imio/db/imgnfn.x b/sys/imio/db/imgnfn.x new file mode 100644 index 00000000..2dca4d9f --- /dev/null +++ b/sys/imio/db/imgnfn.x @@ -0,0 +1,339 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <ctype.h> +include <imhdr.h> +include <imio.h> +include "idb.h" + +.help imgnfn +.nf -------------------------------------------------------------------------- +IMGNFN -- Template expansion for image header keywords. + + list = imofnl[su] (im, template) # open list + nch = imgnfn (im, outstr, maxch) # get next field name + imcfnl (im) # close list + +IMOFNLS opens the list sorted, whereas IMOFNLU opens it unsorted. Both std. +and user header keywords are included in the list. +.endhelp --------------------------------------------------------------------- + +define MAX_FIELDS 1024 +define SZ_SBUF 8192 +define LEN_FNSTRUCT (10+MAX_FIELDS) + +define FN_NENTRIES Memi[$1] # number of field names in list +define FN_NEXT Memi[$1+1] # next string to be returned +define FN_SBUF Memi[$1+2] # pointer to string buffer + # open +define FN_STRP Memi[$1+10+$2-1] # array of str ptrs +define FN_FIELDNAME Memc[FN_STRP($1,$2)] # reference a string + + +# IMGNFN -- Get the next field name matching the given template from an image +# header database. Sorting of the field list is optional. A prior call to +# IMOFNL[SU] is necessary to open the sorted or unsorted list. + +int procedure imgnfn (fn, outstr, maxch) + +pointer fn # field name list descriptor +char outstr[ARB] # output string +int maxch + +int strnum +int gstrcpy() + +begin + strnum = FN_NEXT(fn) + if (strnum > FN_NENTRIES(fn)) + return (EOF) + FN_NEXT(fn) = strnum + 1 + + return (gstrcpy (FN_FIELDNAME(fn,strnum), outstr, maxch)) +end + + +# IMOFNLS -- Open a sorted field name list. + +pointer procedure imofnls (im, template) + +pointer im # image descriptor +char template[ARB] # field name template +pointer imofnl() + +begin + return (imofnl (im, template, YES)) +end + + +# IMOFNLU -- Open an unsorted field name list. + +pointer procedure imofnlu (im, template) + +pointer im # image descriptor +char template[ARB] # field name template +pointer imofnl() + +begin + return (imofnl (im, template, NO)) +end + + +# IMCFNL -- Close the image header field name list and return all associated +# storage. + +procedure imcfnl (fn) + +pointer fn # field name list descriptor + +begin + call mfree (FN_SBUF(fn), TY_CHAR) + call mfree (fn, TY_STRUCT) +end + + +# IMOFNL -- Open an image header field name list, either sorted or unsorted. +# A template is a list of patterns delimited by commas. + +pointer procedure imofnl (im, template, sort) + +pointer im # image descriptor +char template[ARB] # field name template +int sort # sort flag + +bool escape +int tp, nstr, ch, junk, first_string, nstrings, nmatch, i +pointer sp, ip, op, fn, kwname, sbuf, pattern, patcode, nextch +int patmake(), patmatch(), strlen() +errchk syserr + +begin + call smark (sp) + call salloc (kwname, SZ_FNAME, TY_CHAR) + call salloc (pattern, SZ_FNAME, TY_CHAR) + call salloc (patcode, SZ_LINE, TY_CHAR) + + # Allocate field list descriptor. + call calloc (fn, LEN_FNSTRUCT, TY_STRUCT) + call malloc (sbuf, SZ_SBUF, TY_CHAR) + + FN_SBUF(fn) = sbuf + nextch = sbuf + nstr = 0 + tp = 1 + + # Extract each comma delimited template, expand upon image header + # field list, sort if desired, and add strings to list. + + while (template[tp] != EOS && template[tp] != '\n') { + # Advance to next field. + while (IS_WHITE(template[tp]) || template[tp] == ',') + tp = tp + 1 + + # Extract pattern. Enclose pattern in ^{} so that the match will + # occur only at the beginning of each line and will be case + # insensitive (req'd for FITS format). + + op = pattern + Memc[op] = '^' + op = op + 1 + Memc[op] = '{' + op = op + 1 + + # A field name of the form "$", "$x", etc. is not matched against + # the actual image field list, but is included in the output field + # list as a literal. + + ch = template[tp] + escape = (ch == '$') + + while (! (IS_WHITE(ch) || ch == '\n' || ch == ',' || ch == EOS)) { + # Map "*" into "?*". + if (ch == '*') { + Memc[op] = '?' + op = op + 1 + } + + Memc[op] = ch + op = op + 1 + tp = tp + 1 + ch = template[tp] + } + + Memc[op] = '}' + op = op + 1 + Memc[op] = EOS + + # If the pattern is a literal, put it in the output list without + # matching it against the image field list. + + if (escape) { + # Omit the leading "^{" and the trailing "}". + ip = pattern + 2 + op = op - 1 + Memc[op] = EOS + call imfn_putkey (Memc[ip], FN_STRP(fn,1), nstr, nextch, sbuf) + + } else { + # Encode pattern. + junk = patmake (Memc[pattern], Memc[patcode], SZ_LINE) + + # Scan database and extract all field names matching the + # pattern. Mark number of first string for the sort. + + first_string = nstr + 1 + + # First find any standard header keywords matching the pattern. + call imfn_stdkeys (im, Memc[patcode], FN_STRP(fn,1), nstr, + nextch, sbuf) + + # Now scan the user area. + for (ip=IM_USERAREA(im); Memc[ip] != EOS; ip=ip+1) { + # Skip entries that are not keywords. + if (Memc[ip+8] == '=') { + + # Extract keyword name. + Memc[kwname+8] = EOS + do i = 1, 8 { + ch = Memc[ip+i-1] + if (ch == ' ') { + Memc[kwname+i-1] = EOS + break + } else + Memc[kwname+i-1] = ch + } + + # Check for a match. + if (Memc[kwname] != EOS) { + # Put key in list if it matches. + nmatch = patmatch (Memc[kwname], Memc[patcode]) - 1 + if (nmatch > 0 && nmatch == strlen(Memc[kwname])) + call imfn_putkey (Memc[ip], + FN_STRP(fn,1), nstr, nextch, sbuf) + } + } + + # Advance to the next record. + if (IM_UABLOCKED(im) == YES) + ip = ip + IDB_RECLEN + else { + while (Memc[ip] != '\n' && Memc[ip] != EOS) + ip = ip + 1 + } + + if (Memc[ip] == EOS) + break + } + + # Sort the newly added keywords. + nstrings = nstr - first_string + 1 + if (sort == YES && nstrings > 1) + call strsrt (FN_STRP(fn,first_string), Memc, nstrings) + } + } + + FN_NENTRIES(fn) = nstr + FN_NEXT(fn) = 1 + + call sfree (sp) + return (fn) +end + + +# IMFN_STDKEYS -- Match a pattern (encoded) against the list of standard header +# keywords, both with and without the "i_" prefix. Add the full name (with i_ +# prefix) of each name matched to the keyword list. + +procedure imfn_stdkeys (im, patcode, strp, nstr, nextch, sbuf) + +pointer im # image descriptor +char patcode[ARB] # encoded pattern +pointer strp[ARB] # array of string pointers +int nstr # current number of strings +pointer nextch # next available char in string buffer +pointer sbuf # string buffer + +pointer sp, op, key +bool validfield, match +int ip, index, nmatch +int patmatch(), strlen() + +string keywords "|ctime|history|limtime|maxpixval|minpixval|mtime|naxis\ +|naxis1|naxis2|naxis3|naxis4|naxis5|naxis6|naxis7|pixfile|pixtype|title|" +errchk imfn_putkey + +begin + call smark (sp) + call salloc (key, SZ_FNAME, TY_CHAR) + + call strcpy ("i_", Memc[key], SZ_FNAME) + index = 1 + + for (ip=2; keywords[ip] != EOS; ip=ip+1) { + # Do not put dimensions NAXIS1, NAXIS2, etc. higher than the + # actual image dimension into the matched list. + + validfield = true + if (index >= 8 && index <= 14) + validfield = (index - 7 <= IM_NDIM(im)) + + # Extract keyword into buffer, after the "i_". + for (op=key+2; keywords[ip] != '|'; op=op+1) { + Memc[op] = keywords[ip] + ip = ip + 1 + } + Memc[op] = EOS + + if (validfield) { + nmatch = patmatch (Memc[key], patcode) - 1 + match = (nmatch > 0 && nmatch == strlen(Memc[key])) + if (!match) { + nmatch = patmatch (Memc[key+2], patcode) - 1 + match = (nmatch > 0 && nmatch == strlen(Memc[key+2])) + } + if (match) + call imfn_putkey (Memc[key], strp, nstr, nextch, sbuf) + } + + index = index + 1 + } + + call sfree (sp) +end + + +# IMFN_PUTKEY -- Put a keyword into the keyword list. + +procedure imfn_putkey (key, strp, nstr, nextch, sbuf) + +char key[ARB] # keyword name (etc.) +pointer strp[ARB] # array of string pointers +int nstr # current number of strings +pointer nextch # next available char in string buffer +pointer sbuf # string buffer + +int ch, ip +errchk syserr + +begin + # Append keyword to the string buffer. + nstr = nstr + 1 + if (nstr > MAX_FIELDS) + call syserr (SYS_IMFNOVFL) + strp[nstr] = nextch + + ip = 1 + ch = key[ip] + + while (ch != '=' && ch != ' ' && ch != EOS) { + Memc[nextch] = ch + nextch = nextch + 1 + if (nextch >= sbuf + SZ_SBUF) + call syserr (SYS_IMFNOVFL) + ip = ip + 1 + ch = key[ip] + } + + Memc[nextch] = EOS + nextch = nextch + 1 +end diff --git a/sys/imio/db/imgstr.x b/sys/imio/db/imgstr.x new file mode 100644 index 00000000..53a77d4c --- /dev/null +++ b/sys/imio/db/imgstr.x @@ -0,0 +1,52 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <ctype.h> +include "idb.h" + +# IMGSTR -- Get an image header parameter of type string. If the named +# parameter is a standard parameter return the value directly, else scan +# the user area for the named parameter and decode the value. A special +# check is required for embedded single quotes as per the FITS standard. + +procedure imgstr (im, key, outstr, maxch) + +pointer im # image descriptor +char key[ARB] # parameter to be returned +char outstr[ARB] # output string to receive parameter value +int maxch + +pointer rp +int ip, op +int idb_getstring(), idb_findrecord(), ctowrd(), strlen() +errchk syserrs + +begin + # Check for a standard header parameter first. + if (idb_getstring (im, key, outstr, maxch) != ERR) + return + + # Find the record. + if (idb_findrecord (im, key, rp) == 0) + call syserrs (SYS_IDBKEYNF, key) + + ip = IDB_STARTVALUE + if (ctowrd (Memc[rp], ip, outstr, maxch) > 0) { + # Check for embedded single quotes which are represented as ''. + repeat { + if (Memc[rp+ip-1] != '\'') + break + call strcat ("'", outstr, maxch) + op = strlen (outstr) + 1 + if (ctowrd (Memc[rp], ip, outstr[op], maxch-op) == 0) + break + } + + # Strip trailing whitespace. + op = strlen (outstr) + while (op > 0 && (IS_WHITE(outstr[op]) || outstr[op] == '\n')) + op = op - 1 + outstr[op+1] = EOS + } else + outstr[1] = EOS +end diff --git a/sys/imio/db/impstr.x b/sys/imio/db/impstr.x new file mode 100644 index 00000000..4f4985cf --- /dev/null +++ b/sys/imio/db/impstr.x @@ -0,0 +1,120 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include "idb.h" + +# IMPSTR -- Put an image header parameter of type string. If the named +# parameter is a standard parameter of type other than string, decode the +# string and set the binary value of the parameter. If the parameter is +# a nonstandard one we can do a simple string edit, since user parameters +# are stored in the user area in string form. The datatype of the parameter +# must be preserved by the edit, i.e., parameters of actual datatype string +# must be quoted and left justified and other parameters must be unquoted +# and right justified in the value field. + +procedure impstr (im, key, value) + +pointer im #I image descriptor +char key[ARB] #I parameter to be set +char value[ARB] #I new parameter value + +bool string_valued +int nchars, ch, i +pointer rp, ip, op, sp, val, start, text, cmmt +int idb_putstring(), idb_findrecord(), idb_filstr() +errchk syserrs + +begin + call smark (sp) + call salloc (val, SZ_LINE, TY_CHAR) + call salloc (text, SZ_LINE, TY_CHAR) + call salloc (cmmt, SZ_LINE, TY_CHAR) + + # Filter the value string to remove any undesirable characters. + nchars = idb_filstr (value, Memc[text], SZ_LINE) + + # Check for a standard header parameter first. + if (idb_putstring (im, key, Memc[text]) != ERR) { + call sfree (sp) + return + } + + # Find the record. + if (idb_findrecord (im, key, rp) == 0) + call syserrs (SYS_IDBKEYNF, key) + + # Determine the actual datatype of the parameter. String valued + # parameters will have an apostrophe in the first nonblank column + # of the value field. Skip the value and treat the rest of + # the line as a comment to be preserved. + + string_valued = false + for (ip=IDB_STARTVALUE; ip <= IDB_ENDVALUE; ip=ip+1) { + # Skip leading whitespace. + for (; Memc[rp+ip-1] == ' '; ip=ip+1) + ; + + if (Memc[rp+ip-1] == '\'') { + # Skip string value. + do i = ip, IDB_RECLEN { + ch = Memc[rp+i] + if (ch == '\n') + break + Memc[rp+i] = ' ' + if (ch == '\'') + break + } + + string_valued = true + break + + } else { + # Skip numeric value. + do i = ip, IDB_RECLEN { + ch = Memc[rp+i-1] + if (ch == '\n' || ch == ' ' || ch == '/') + break + Memc[rp+i-1] = ' ' + } + break + } + } + + # Skip whitespace before any comment. + for (ip = i; Memc[rp+ip-1] == ' '; ip=ip+1) + ; + + # Save comment. Include a leading space and add a / if missing. + Memc[cmmt] = ' ' + for (i = 1; Memc[rp+ip-1] != '\n'; ip=ip+1) { + if (i == 1 && Memc[rp+ip-1] != '/') { + Memc[cmmt+i] = '/' + i = i + 1 + } + Memc[cmmt+i] = Memc[rp+ip-1] + Memc[rp+ip-1] = ' ' + i = i + 1 + } + Memc[cmmt+i] = EOS + + # Encode the new value of the parameter. + if (string_valued) { + call sprintf (Memc[val], SZ_LINE, " '%-0.68s%11t'%22t%-0.68s") + call pargstr (Memc[text]) + call pargstr (Memc[cmmt]) + } else { + call sprintf (Memc[val], SZ_LINE, "%21s%-0.68s") + call pargstr (Memc[text]) + call pargstr (Memc[cmmt]) + } + + # Update the parameter value. + op = rp + IDB_STARTVALUE - 1 + start = op + for (ip=val; Memc[ip] != EOS && Memc[op] != '\n'; ip=ip+1) { + Memc[op] = Memc[ip] + op = op + 1 + } + + call sfree (sp) +end diff --git a/sys/imio/db/imputb.x b/sys/imio/db/imputb.x new file mode 100644 index 00000000..a211f464 --- /dev/null +++ b/sys/imio/db/imputb.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMPUTB -- Put an image header parameter of type boolean. + +procedure imputb (im, key, bval) + +pointer im # image descriptor +char key[ARB] # parameter to be set +bool bval # parameter value +char sval[2] + +begin + if (bval) + sval[1] = 'T' + else + sval[1] = 'F' + sval[2] = EOS + + call impstr (im, key, sval) +end diff --git a/sys/imio/db/imputd.x b/sys/imio/db/imputd.x new file mode 100644 index 00000000..ccd5339a --- /dev/null +++ b/sys/imio/db/imputd.x @@ -0,0 +1,38 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# IMPUTD -- Put an image header parameter of type double. + +procedure imputd (im, key, dval) + +pointer im # image descriptor +char key[ARB] # parameter to be set +double dval # double precision value + +pointer sp, sval +int i, strlen() + +begin + call smark (sp) + call salloc (sval, SZ_FNAME, TY_CHAR) + + # Reduce the precision of the encoded value if necessary to fit in + # the FITS value field. Start with NDIGITS_DP-1 as the precision + # estimate NDIGITS_DP is only approximate, and if we make up half a + # digit of precision the result can be 1.00000000000000001 instead + # of 1.0. + + for (i=NDIGITS_DP-1; i >= NDIGITS_RP; i=i-1) { + call sprintf (Memc[sval], SZ_FNAME, "%0.*g") + call pargi (i) + call pargd (dval) + if (strlen (Memc[sval]) < 20) + break + } + + # Write the new value to the header. + call impstr (im, key, Memc[sval]) + + call sfree (sp) +end diff --git a/sys/imio/db/imputh.x b/sys/imio/db/imputh.x new file mode 100644 index 00000000..39467366 --- /dev/null +++ b/sys/imio/db/imputh.x @@ -0,0 +1,161 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <ctype.h> +include <imhdr.h> +include <imio.h> +include "idb.h" + +define LEN_HISTSTR 70 # length of a history string on a FITS card + +# IMPUTH -- Add a FITS-like history/comment field to the image header. +# Only keywords HISTORY, COMMENT, or " " (eight spaces) are allowed! +# (At least for the present - in the future this routine will probably +# append FITS cards to a distinct FITS-table appearing as a table parameter +# in the generalized image header. Also, since it is not yet decided how +# image history will be handled in the future, there is no guarantee that +# this routine will remain unchanged - it may change or be obsoleted.) + +procedure imputh (im, key, text) + +pointer im #I image descriptor +char key[ARB] #I name of the new parameter +char text[ARB] #I the history string to be added + +pointer sp, keyname, instr, outstr, ua +int fd, max_lenuserarea, curlen, buflen, nchars +int ip, op, in_last_blank, out_last_blank + +bool streq() +int stropen(), strlen(), idb_filstr() +errchk syserrs, stropen, fprintf + +begin + call smark (sp) + call salloc (instr, SZ_LINE, TY_CHAR) + call salloc (keyname, SZ_FNAME, TY_CHAR) + call salloc (outstr, LEN_HISTSTR, TY_CHAR) + + # FITS format requires that the keyword name be upper case. + call strcpy (key, Memc[keyname], SZ_FNAME) + call strupr (Memc[keyname]) + + # Only standard FITS HISTORY keywords are allowed. + if (!(streq(Memc[keyname],"HISTORY") || + streq(Memc[keyname],"COMMENT") || + streq(Memc[keyname]," "))) { + + call eprintf ("IMPUTH: Invalid history keyword `%s' ignored\n") + call pargstr (key) + call sfree (sp) + return + } + + # Open the user area string for appending. 'buflen' is the malloc-ed + # buffer length in struct units; IMU is the struct offset to the user + # area, i.e., the size of that part of the image descriptor preceding + # the user area. If the buffer fills we must allow one extra char for + # the EOS delimiter; since storage for the image descriptor was + # allocated in struct units the storage allocator will not have + # allocated space for the extra EOS char. + + ua = IM_USERAREA(im) + curlen = strlen (Memc[ua]) + buflen = LEN_IMDES + IM_LENHDRMEM(im) + max_lenuserarea = (buflen - IMU) * SZ_STRUCT - 1 + + # If the user area is not empty the last character must be the newline + # record delimiter, else the new record we add will be invalid. + + if (curlen > 0 && Memc[ua+curlen-1] != '\n') + if (curlen >= max_lenuserarea) + call syserrs (SYS_IDBOVFL, key) + else { + Memc[ua+curlen] = '\n' + curlen = curlen + 1 + Memc[ua+curlen] = EOS + } + + # Open a file descriptor on the userarea buffer. + fd = stropen (Memc[ua+curlen], max_lenuserarea-curlen, APPEND) + + # Filter the input string to remove any undesirable characters. + nchars = idb_filstr (text, Memc[instr], SZ_LINE) + + # Append the HISTORY or COMMENT record to the user area. + iferr { + if (nchars <= LEN_HISTSTR ) { + # This is the easy case: the HISTORY string will fit in + # one record. + + call fprintf (fd, "%-8s %s%*t\n") + call pargstr (Memc[keyname]) + call pargstr (Memc[instr]) + call pargi (IDB_LENSTRINGRECORD + 1) + + } else { + # Not the simple case; break up the string into pieces that + # will fit into LEN_HISTSTR, preferably on word boundaries. + + for (ip=1; Memc[instr+ip-1] != EOS; ) { + # If no blanks are found in HISTORY string, make sure + # all of it gets output anyway. + + in_last_blank = ip + LEN_HISTSTR - 1 + out_last_blank = LEN_HISTSTR + + # Copy the string to the output buffer, marking the + # last blank found. + + do op = 1, LEN_HISTSTR { + if (IS_WHITE (Memc[instr+ip-1])) { + in_last_blank = ip + out_last_blank = op + } else if (Memc[instr+ip-1] == EOS) + break + + Memc[outstr+op-1] = Memc[instr+ip-1] + ip = ip + 1 + } + + # The output string is full; close it off properly + # and get ready for the next round (if any). + + Memc[outstr+op-1] = EOS + if (Memc[instr+ip-1] != EOS) { + # Break at last word boundary if in a word. + if (!IS_WHITE (Memc[instr+ip-1])) { + Memc[outstr+out_last_blank] = EOS + ip = in_last_blank + 1 + } + + # Skip leading whitespace on next line. + while (IS_WHITE(Memc[instr+ip-1])) + ip = ip + 1 + } + + # Write out the FITS HISTORY card. + call fprintf (fd, "%-8s %s%*t\n") + call pargstr (Memc[keyname]) + call pargstr (Memc[outstr]) + call pargi (IDB_LENSTRINGRECORD + 1) + } + } + + } then { + # Out of space in the user area. Discard the truncated card + # at the end of the buffer by backing up to the last newline and + # writing an EOS. + + call close (fd) + for (ip=ua+max_lenuserarea-1; ip > ua; ip=ip-1) + if (Memc[ip] == '\n') { + Memc[ip+1] = EOS + break + } + call syserrs (SYS_IDBOVFL, key) + } + + call close (fd) + call sfree (sp) +end diff --git a/sys/imio/db/imputi.x b/sys/imio/db/imputi.x new file mode 100644 index 00000000..8be50d16 --- /dev/null +++ b/sys/imio/db/imputi.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMPUTI -- Put an image header parameter of type integer. + +procedure imputi (im, key, ival) + +pointer im # image descriptor +char key[ARB] # parameter to be set +int ival # parameter value +pointer sp, sval + +begin + call smark (sp) + call salloc (sval, SZ_FNAME, TY_CHAR) + + call sprintf (Memc[sval], SZ_FNAME, "%d") + call pargi (ival) + call impstr (im, key, Memc[sval]) + + call sfree (sp) +end diff --git a/sys/imio/db/imputl.x b/sys/imio/db/imputl.x new file mode 100644 index 00000000..3bc0d64c --- /dev/null +++ b/sys/imio/db/imputl.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMPUTL -- Put an image header parameter of type long integer. + +procedure imputl (im, key, lval) + +pointer im # image descriptor +char key[ARB] # parameter to be set +long lval # parameter value +pointer sp, sval + +begin + call smark (sp) + call salloc (sval, SZ_FNAME, TY_CHAR) + + call sprintf (Memc[sval], SZ_FNAME, "%d") + call pargl (lval) + call impstr (im, key, Memc[sval]) + + call sfree (sp) +end diff --git a/sys/imio/db/imputr.x b/sys/imio/db/imputr.x new file mode 100644 index 00000000..13a5e0c3 --- /dev/null +++ b/sys/imio/db/imputr.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# IMPUTR -- Put an image header parameter of type real. + +procedure imputr (im, key, rval) + +pointer im # image descriptor +char key[ARB] # parameter to be set +real rval # parameter value +pointer sp, sval + +begin + call smark (sp) + call salloc (sval, SZ_FNAME, TY_CHAR) + + call sprintf (Memc[sval], SZ_FNAME, "%0.*g") + call pargi (NDIGITS_RP) + call pargr (rval) + call impstr (im, key, Memc[sval]) + + call sfree (sp) +end diff --git a/sys/imio/db/imputs.x b/sys/imio/db/imputs.x new file mode 100644 index 00000000..98fd61d8 --- /dev/null +++ b/sys/imio/db/imputs.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMPUTS -- Put an image header parameter of type short integer. + +procedure imputs (im, key, value) + +pointer im # image descriptor +char key[ARB] # parameter to be set +short value # parameter value +pointer sp, sval + +begin + call smark (sp) + call salloc (sval, SZ_FNAME, TY_CHAR) + + call sprintf (Memc[sval], SZ_FNAME, "%d") + call pargs (value) + call impstr (im, key, Memc[sval]) + + call sfree (sp) +end diff --git a/sys/imio/db/imrenf.x b/sys/imio/db/imrenf.x new file mode 100644 index 00000000..3b1bf7a6 --- /dev/null +++ b/sys/imio/db/imrenf.x @@ -0,0 +1,44 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include "idb.h" + +# IMRENF -- Rename a user field keyword. It is an error if the +# named field does not exist. + +procedure imrenf (im, oldkey, newkey) + +pointer im # image descriptor +char oldkey[ARB] # old keyword +char newkey[ARB] # new keyword + +int off +pointer rp, sp, keyname +int idb_kwlookup(), idb_findrecord(), stridxs() +errchk syserrs + +begin + call smark (sp) + call salloc (keyname, SZ_FNAME, TY_CHAR) + + # FITS format requires that the keyword name be upper case. + call strcpy (oldkey, Memc[keyname], IDB_SZFITSKEY) + call strupr (Memc[keyname]) + + # Cannot delete standard header keywords. + if (idb_kwlookup (oldkey) > 0) + call syserrs (SYS_IDBNODEL, oldkey) + + # Verify that the named user field exists. + if (idb_findrecord (im, oldkey, rp) <= 0) + call syserrs (SYS_IDBDELNXKW, oldkey) + + # Rename the keyword. + call sprintf (Memc[keyname], IDB_SZFITSKEY, "%-8.8s") + call pargstr (newkey) + call strupr (Memc[keyname]) + call amovc (Memc[keyname], Memc[rp], 8) + + call sfree (sp) +end diff --git a/sys/imio/db/mkpkg b/sys/imio/db/mkpkg new file mode 100644 index 00000000..2d8888df --- /dev/null +++ b/sys/imio/db/mkpkg @@ -0,0 +1,44 @@ +# Update the image header database interface. + +$checkout libex.a lib$ +$update libex.a +$checkin libex.a lib$ +$exit + +libex.a: + idbcard.x idb.h <imhdr.h> <imio.h> + idbfind.x idb.h <imhdr.h> <imio.h> + idbfstr.x <ctype.h> + idbgstr.x idb.h <ctype.h> <imhdr.h> + idbkwlu.x <ctype.h> <imhdr.h> + idbpstr.x idb.h <ctype.h> <imhdr.h> <mach.h> + imaccf.x + imaddb.x + imaddd.x + imaddf.x idb.h <fset.h> <imhdr.h> <imio.h> + imaddi.x + imaddl.x + imaddr.x + imadds.x + imastr.x + imdelf.x idb.h <imhdr.h> + imgetb.x idb.h + imgetc.x + imgetd.x idb.h + imgeti.x + imgetl.x + imgetr.x + imgets.x + imgftype.x idb.h <ctype.h> + imgnfn.x idb.h <ctype.h> <imhdr.h> <imio.h> + imgstr.x idb.h <ctype.h> + impstr.x idb.h + imputb.x + imputd.x <mach.h> + imputh.x idb.h <ctype.h> <imhdr.h> <imio.h> + imputi.x + imputl.x + imputr.x <mach.h> + imputs.x + imrenf.x idb.h <imhdr.h> + ; diff --git a/sys/imio/dbc/README b/sys/imio/dbc/README new file mode 100644 index 00000000..4e6a89ac --- /dev/null +++ b/sys/imio/dbc/README @@ -0,0 +1,29 @@ +October 4, 2004 + +These routines represent an extension to the imio header routines manipulation. +Most of them have a new parameter which is the FITS header comment field. +The routine names have changed slighly to avoid collision and to have some +meaning; e.g. the ending 'c' for comment. + +There are a couple of new routines to handle only comments. + +Nelson Zarate + + +imakbc.x:# IMAKBC -- Add a new field to the image header and initialize to the value +imakdc.x:# IMAKDC -- Add a new field to the image header and initialize to the value +imakic.x:# IMAKIC -- Add a new field to the image header and initialize to the value +imaklc.x:# IMAKLC -- Add a new field to the image header and initialize to the value +imakrc.x:# IMAKRC -- Add a new field to the image header and initialize to the value +imaksc.x:# IMAKSC -- Add a new field to the image header and initialize to the value +imastrc.x:# IMASTRC -- Add a new field to the image header and initialize to the value +imgcom.x:# IMGCOM -- Get the comment field for a keyword. +impcom.x:# IMPCOM -- Change the comment field for a keyword. +impkbc.x:# IMPKBC -- Put an image header parameter of type boolean. +impkdc.x:# IMPKDDC -- Put an image header parameter of type double. +impkic.x:# IMPKIC -- Put an image header parameter of type integer. +impklc.x:# IMPKLC -- Put an image header parameter of type long integer. +impkrc.x:# IMPKRC -- Put an image header parameter of type real. +imdrmcom.x:# IMDRMCOM -- Remove the comment field for a keyword. +impksc.x:# IMPKSC -- Put an image header parameter of type short integer. +impstrc.x:# IMPSTRC -- Put an image header parameter of type string. If the named diff --git a/sys/imio/dbc/idbc.h b/sys/imio/dbc/idbc.h new file mode 100644 index 00000000..3c254469 --- /dev/null +++ b/sys/imio/dbc/idbc.h @@ -0,0 +1,27 @@ +# IDB.H -- Image header database interface. In this version of the interface +# the standard image header fields are maintained in binary in a fixed +# structure and the user fields are maintained in FITS format (text) in the +# a string buffer following the binary image header. + +define IDB_RECLEN 80 # length of a FITS record (card) +define IDB_STARTVALUE 10 # first column of value field +define IDB_ENDVALUE 30 # last column of value field +define IDB_LENNUMERICRECORD 80 # length of new numeric records +define IDB_LENSTRINGRECORD 80 # length of new string records +define IDB_SZFITSKEY 8 # max length FITS keyword + +# Standard header keywords accessible via the database interface. + +define I_CTIME 1 +define I_HISTORY 2 +define I_LIMTIME 3 +define I_MAXPIXVAL 4 +define I_MINPIXVAL 5 +define I_MTIME 6 +define I_NAXIS 7 +define I_PIXFILE 8 +define I_PIXTYPE 9 +define I_TITLE 10 + +define BEFORE 1 +define AFTER 2 diff --git a/sys/imio/dbc/imakbc.x b/sys/imio/dbc/imakbc.x new file mode 100644 index 00000000..2871370d --- /dev/null +++ b/sys/imio/dbc/imakbc.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMAKBC -- Add a new field to the image header and initialize to the value +# given. It is not an error if the parameter already exists. + +procedure imakbc (im, key, value, comment) + +pointer im # image descriptor +char key[ARB] # parameter or field value +bool value # new or initial value of parameter +char comment[ARB] # comment + +int imaccf() +errchk imaccf, imaddf + +begin + if (imaccf (im, key) == NO) + call imaddf (im, key, "b") + call impkbc (im, key, value, comment) +end diff --git a/sys/imio/dbc/imakbci.x b/sys/imio/dbc/imakbci.x new file mode 100644 index 00000000..3fe64116 --- /dev/null +++ b/sys/imio/dbc/imakbci.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMAKBCI -- Insert a new field to the image header after the given keyword +# and initialize to the value +# given. It is not an error if the parameter already exists. + +procedure imakbci (im, key, value, comment, pkey, baf) + +pointer im # image descriptor +char key[ARB] # parameter or field value +bool value # new or initial value of parameter +char comment[ARB] # comment +char pkey[ARB] # Pivot keyword to insert 'key' +int baf # I Insert BEFORE or AFTER + +int imaccf() +errchk imaccf, iminfi + +begin + if (imaccf (im, key) == NO) + call iminfi (im, key, pkey, "b", baf) + call impkbc (im, key, value, comment) +end diff --git a/sys/imio/dbc/imakdc.x b/sys/imio/dbc/imakdc.x new file mode 100644 index 00000000..787c496d --- /dev/null +++ b/sys/imio/dbc/imakdc.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMAKDC -- Add a new field to the image header and initialize to the value +# given. It is not an error if the parameter already exists. + +procedure imakdc (im, key, value, comment) + +pointer im # image descriptor +char key[ARB] # parameter or field value +double value # new or initial value of parameter +char comment[ARB] # comment + +int imaccf() +errchk imaccf, imaddf + +begin + if (imaccf (im, key) == NO) + call imaddf (im, key, "d") + call impkdc (im, key, value, comment) +end diff --git a/sys/imio/dbc/imakdci.x b/sys/imio/dbc/imakdci.x new file mode 100644 index 00000000..c63a9a5a --- /dev/null +++ b/sys/imio/dbc/imakdci.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMAKDCI -- Insert a new field to the image header after the given keyword +# and initialize to the value +# given. It is not an error if the parameter already exists. + +procedure imakdci (im, key, value, comment, pkey, baf) + +pointer im # image descriptor +char key[ARB] # parameter or field value +double value # new or initial value of parameter +char comment[ARB] # comment +char pkey[ARB] # Pivot keyword to insert 'key' +int baf # I Insert BEFORE or AFTER + +int imaccf() +errchk imaccf, iminfi + +begin + if (imaccf (im, key) == NO) + call iminfi (im, key, pkey, "d", baf) + call impkdc (im, key, value, comment) +end diff --git a/sys/imio/dbc/imakic.x b/sys/imio/dbc/imakic.x new file mode 100644 index 00000000..10594d2a --- /dev/null +++ b/sys/imio/dbc/imakic.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMAKIC -- Add a new field to the image header and initialize to the value +# given. It is not an error if the parameter already exists. + +procedure imakic (im, key, value, comment) + +pointer im # image descriptor +char key[ARB] # parameter or field value +int value # new or initial value of parameter +char comment[ARB] + +int imaccf() +errchk imaccf, imaddf + +begin + if (imaccf (im, key) == NO) + call imaddf (im, key, "i") + call impkic (im, key, value, comment) +end diff --git a/sys/imio/dbc/imakici.x b/sys/imio/dbc/imakici.x new file mode 100644 index 00000000..02177184 --- /dev/null +++ b/sys/imio/dbc/imakici.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMAKICI -- Insert a new field to the image header after the given keyword +# and initialize to the value given. It is not an error if the parameter +# already exists. + +procedure imakici (im, key, value, comment, pkey, baf) + +pointer im # image descriptor +char key[ARB] # parameter or field value +int value # new or initial value of parameter +char comment[ARB] +char pkey[ARB] # Pivot keyword to insert 'key' +int baf # I Insert BEFORE or AFTER + +int imaccf() +errchk imaccf, iminfi + +begin + if (imaccf (im, key) == NO) + call iminfi (im, key, pkey, "i", baf) + call impkic (im, key, value, comment) +end diff --git a/sys/imio/dbc/imaklc.x b/sys/imio/dbc/imaklc.x new file mode 100644 index 00000000..3cb323c1 --- /dev/null +++ b/sys/imio/dbc/imaklc.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMAKLC -- Add a new field to the image header and initialize to the value +# given. It is not an error if the parameter already exists. + +procedure imaklc (im, key, value, comment) + +pointer im # image descriptor +char key[ARB] # parameter or field value +long value # new or initial value of parameter +char comment[ARB] + +int imaccf() +errchk imaccf, imaddf + +begin + if (imaccf (im, key) == NO) + call imaddf (im, key, "l") + call impklc (im, key, value, comment) +end diff --git a/sys/imio/dbc/imaklci.x b/sys/imio/dbc/imaklci.x new file mode 100644 index 00000000..9b74c82f --- /dev/null +++ b/sys/imio/dbc/imaklci.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMAKLCI -- Insert a new field to the image header after the given keyword +# and initialize to the value +# given. It is not an error if the parameter already exists. + +procedure imaklci (im, key, value, comment, pkey, baf) + +pointer im # image descriptor +char key[ARB] # parameter or field value +long value # new or initial value of parameter +char comment[ARB] +char pkey[ARB] # Pivot keyword to insert 'key' +int baf # I Insert BEFORE or AFTER + +int imaccf() +errchk imaccf, iminfi + +begin + if (imaccf (im, key) == NO) + call iminfi (im, key, pkey, "l", baf) + call impklc (im, key, value, comment) +end diff --git a/sys/imio/dbc/imakrc.x b/sys/imio/dbc/imakrc.x new file mode 100644 index 00000000..ff13efdf --- /dev/null +++ b/sys/imio/dbc/imakrc.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMAKRC -- Add a new field to the image header and initialize to the value +# given. It is not an error if the parameter already exists. + +procedure imakrc (im, key, value, comment) + +pointer im # image descriptor +char key[ARB] # parameter or field value +real value # new or initial value of parameter +char comment[ARB] + +int imaccf() +errchk imaccf, imaddf + +begin + if (imaccf (im, key) == NO) + call imaddf (im, key, "r") + call impkrc (im, key, value, comment) +end diff --git a/sys/imio/dbc/imakrci.x b/sys/imio/dbc/imakrci.x new file mode 100644 index 00000000..74114d90 --- /dev/null +++ b/sys/imio/dbc/imakrci.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMAKRCI -- Insert a new field to the image header after the given keyword +# and initialize to the value +# given. It is not an error if the parameter already exists. + +procedure imakrci (im, key, value, comment, pkey, baf) + +pointer im # image descriptor +char key[ARB] # parameter or field value +real value # new or initial value of parameter +char comment[ARB] +char pkey[ARB] # Pivot keyword to insert 'key' +int baf # I Insert BEFORE or AFTER + +int imaccf() +errchk imaccf, iminfi + +begin + if (imaccf (im, key) == NO) + call iminfi (im, key, pkey, "r", baf) + call impkrc (im, key, value, comment) +end diff --git a/sys/imio/dbc/imaksc.x b/sys/imio/dbc/imaksc.x new file mode 100644 index 00000000..e6f2c4ac --- /dev/null +++ b/sys/imio/dbc/imaksc.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMAKSC -- Add a new field to the image header and initialize to the value +# given. It is not an error if the parameter already exists. + +procedure imaksc (im, key, value, comment) + +pointer im # image descriptor +char key[ARB] # parameter or field value +short value # new or initial value of parameter +char comment[ARB] + +int imaccf() +errchk imaccf, imaddf + +begin + if (imaccf (im, key) == NO) + call imaddf (im, key, "s") + call impksc (im, key, value, comment) +end diff --git a/sys/imio/dbc/imaksci.x b/sys/imio/dbc/imaksci.x new file mode 100644 index 00000000..2bed12b0 --- /dev/null +++ b/sys/imio/dbc/imaksci.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMAKSCI -- Insert a new field to the image header after the given keyword +# and initialize to the value +# given. It is not an error if the parameter already exists. + +procedure imaksci (im, key, value, comment, pkey, baf) + +pointer im # image descriptor +char key[ARB] # parameter or field value +short value # new or initial value of parameter +char comment[ARB] +char pkey[ARB] # Pivot keyword to insert 'key' +int baf # I Insert BEFORE or AFTER + +int imaccf() +errchk imaccf, iminfi + +begin + if (imaccf (im, key) == NO) + call iminfi (im, key, pkey, "s", baf) + call impksc (im, key, value, comment) +end diff --git a/sys/imio/dbc/imastrc.x b/sys/imio/dbc/imastrc.x new file mode 100644 index 00000000..4620db46 --- /dev/null +++ b/sys/imio/dbc/imastrc.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMASTRC -- Add a new field to the image header and initialize to the value +# given. It is not an error if the parameter already exists. + +procedure imastrc (im, key, value, comment) + +pointer im # image descriptor +char key[ARB] # parameter or field value +char value[ARB] # new or initial value of parameter +char comment[ARB] # + +int imaccf() +errchk imaccf, imaddf + +begin + if (imaccf (im, key) == NO) + call imaddf (im, key, "c") + call impstrc (im, key, value, comment) +end diff --git a/sys/imio/dbc/imastrci.x b/sys/imio/dbc/imastrci.x new file mode 100644 index 00000000..f5154906 --- /dev/null +++ b/sys/imio/dbc/imastrci.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMASTRCI -- Insert a new field to the image header after the given keyword +# and initialize to the value +# given. It is not an error if the parameter already exists. + +procedure imastrci (im, key, value, comment, pkey, baf) + +pointer im # image descriptor +char key[ARB] # parameter or field value +char value[ARB] # new or initial value of parameter +char comment[ARB] # +char pkey[ARB] # Pivot keyword to insert 'key' +int baf # I Insert BEFORE or AFTER + +int imaccf() +errchk imaccf, iminfi + +begin + if (imaccf (im, key) == NO) + call iminfi (im, key, pkey, "c", baf) + call impstrc (im, key, value, comment) +end diff --git a/sys/imio/dbc/imdrmcom.x b/sys/imio/dbc/imdrmcom.x new file mode 100644 index 00000000..4a10f2df --- /dev/null +++ b/sys/imio/dbc/imdrmcom.x @@ -0,0 +1,96 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include "idbc.h" + +# IMDRMCOM -- Remove the comment field for a keyword. + +procedure imdrmcom (im, key) + +pointer im #I image descriptor +char key[ARB] #I parameter to be set + +bool string_valued +int ch, i, ti, j, n +pointer rp, ip, op, sp, val, start, text, cmmt +int idb_findrecord() +errchk syserrs + +begin + call smark (sp) + call salloc (val, SZ_LINE, TY_CHAR) + call salloc (text, SZ_LINE, TY_CHAR) + call salloc (cmmt, SZ_LINE, TY_CHAR) + + # Find the record. + if (idb_findrecord (im, key, rp) == 0) + call syserrs (SYS_IDBKEYNF, key) + + for (i=0; i<SZ_LINE; i=i+1) + Memc[text+i] = ' ' + Memc[text+SZ_LINE] = EOS + + # Determine the actual datatype of the parameter. String valued + # parameters will have an apostrophe in the first nonblank column + # of the value field. + + string_valued = false + ti = text + for (ip=IDB_STARTVALUE; ip <= IDB_ENDVALUE; ip=ip+1) { + # Skip leading whitespace. + for (; Memc[rp+ip-1] == ' '; ip=ip+1) { + Memc[ti] = Memc[rp+ip-1] + ti = ti + 1 + } + if (Memc[rp+ip-1] == '\'') { + # Get string value. + Memc[ti] = Memc[rp+ip-1] + ti = ti + 1 + do i = ip, IDB_RECLEN { + ch = Memc[rp+i] + Memc[ti] = ch + ti = ti + 1 + if (ch == '\n') + break + if (ch == '\'') + break + } + break + + } else { + # Numeric value. + do i = ip, IDB_RECLEN { + ch = Memc[rp+i-1] + Memc[ti] = ch + ti = ti + 1 + if (ch == '\n' || ch == ' ' || ch == '/') + break + } +# if (ch == ' ') +# ti = ti - 1 + break + } + } + + n = 0 + do j = i, IDB_RECLEN { + ch = Memc[rp+j] + Memc[cmmt+n] = ch + n = n + 1 + if (ch == '\n') { + n = n - 1 + break + } + } + Memc[cmmt+n] = EOS + + # Update the parameter value. + op = rp + IDB_STARTVALUE + ti-text - 1 + start = op + for (ip=ti; Memc[ip] != EOS && Memc[op] != '\n'; ip=ip+1) { + Memc[op] = Memc[ip] + op = op + 1 + } + + call sfree (sp) +end diff --git a/sys/imio/dbc/imgcom.x b/sys/imio/dbc/imgcom.x new file mode 100644 index 00000000..504c0c55 --- /dev/null +++ b/sys/imio/dbc/imgcom.x @@ -0,0 +1,66 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <ctype.h> +include "idbc.h" + +# IMGCOM -- Get the comment field for a keyword. + +procedure imgcom (im, key, comment) + +pointer im #I image descriptor +char key[ARB] #I parameter to be set +char comment[ARB] #O comment string + +bool string_valued +int ch, i, n, j, ic, op +pointer rp, ip, sp, buf +int idb_findrecord(), ctowrd(), stridx(), idb_getstring() +errchk syserrs + +define end_ 91 +begin + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + + # Special fields do not have comment. + if (key[1] == 'i' && key[2] == '_') { + comment[1] = EOS + return + } + + # Find the record. + if (idb_findrecord (im, key, rp) == 0) + call syserrs (SYS_IDBKEYNF, key) + + ip = IDB_STARTVALUE + if (ctowrd (Memc[rp], ip, Memc[buf], SZ_LINE) <= 0) { + comment[1] = EOS + goto end_ + } + + # Look for '/' + while (ip < IDB_RECLEN && (Memc[rp+ip] != '/')) + ip = ip + 1 + if (ip == IDB_RECLEN) { + comment[1] = EOS + goto end_ + } + op = rp+ip+1 + while (op < IDB_RECLEN+rp && (IS_WHITE(Memc[op]) || Memc[op] == '\n')) + op = op + 1 + + # Copy comment section + for (i = 1; Memc[op] != '\n' && op < IDB_RECLEN+rp; op=op+1) { + comment[i] = Memc[op] + i = i + 1 + } + # Trim + i = i - 1 + while (i >= 1 && IS_WHITE(comment[i])) + i = i - 1 + + comment[i+1] = EOS +end_ + call sfree (sp) +end diff --git a/sys/imio/dbc/iminfi.x b/sys/imio/dbc/iminfi.x new file mode 100644 index 00000000..0ddfb540 --- /dev/null +++ b/sys/imio/dbc/iminfi.x @@ -0,0 +1,111 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <fset.h> +include <imhdr.h> +include <imio.h> +include "idbc.h" + +# IMADDFI -- Insert a user field in the image header after the specified +# keyword. It is an error if the named field already exists. + +#procedure imaddfi (im, key, pkey, datatype, baf) +procedure iminfi (im, key, pkey, datatype, baf) + +pointer im #I image descriptor +char key[ARB] #I name of the new parameter +char pkey[ARB] #I 'key' will be inserted bef/after pkey +char datatype[ARB] #I string permits generalization to domains +int baf # I Insert BEFORE or AFTER + +pointer rp, sp, keyname, ua, ip +int fd, max_lenuserarea, curlen, buflen, nchars, piv +int idb_kwlookup(), idb_findrecord() +int strlen(), idb_filstr(), nowhite() +char card[IDB_RECLEN+1] +errchk syserrs, sprintf, pargstr, pargi + +begin + call smark (sp) + call salloc (keyname, SZ_FNAME, TY_CHAR) + + nchars = idb_filstr (key, Memc[keyname], IDB_SZFITSKEY) + nchars = nowhite (Memc[keyname], Memc[keyname], IDB_SZFITSKEY) + call strupr (Memc[keyname]) + + # Check for a redefinition. + if ((idb_kwlookup (key) > 0) || (idb_findrecord (im, key, rp) > 0)) + call syserrs (SYS_IDBREDEF, key) + + # Open the user area string for appending. 'buflen' is the malloc-ed + # buffer length in struct units; IMU is the struct offset to the user + # area, i.e., the size of that part of the image descriptor preceding + # the user area. + + ua = IM_USERAREA(im) + curlen = strlen (Memc[ua]) + buflen = LEN_IMDES + IM_LENHDRMEM(im) + max_lenuserarea = (buflen - IMU) * SZ_STRUCT - 1 + + if (curlen+81 >= max_lenuserarea) { + IM_HDRLEN(im) = LEN_IMHDR + + (curlen + 10*36*81 + SZ_STRUCT-1) / SZ_STRUCT + IM_LENHDRMEM(im) = IM_HDRLEN(im) + (SZ_UAPAD / SZ_STRUCT) + call realloc (im, IM_LENHDRMEM(im) + LEN_IMDES, TY_STRUCT) + buflen = LEN_IMDES + IM_LENHDRMEM(im) + max_lenuserarea = (buflen - IMU) * SZ_STRUCT - 1 + } + + # If the user area is not empty the last character must be the newline + # record delimiter, else the new record we add will be invalid. + + if (curlen > 0 && Memc[ua+curlen-1] != '\n') + if (curlen >= max_lenuserarea) { + call syserrs (SYS_IDBOVFL, key) + } else { + Memc[ua+curlen] = '\n' + curlen = curlen + 1 + Memc[ua+curlen] = EOS + } + + # Find keyw_after + if (idb_findrecord (im, pkey, rp) == 0) { + # Keyw not found. Append the new keyword. + rp = ua+curlen + baf = BEFORE + } else { + # Shift cards after pivot or before pivot + if (baf == AFTER) + piv = rp + else + piv = rp - IDB_RECLEN - 1 + for (ip= ua+curlen-IDB_RECLEN-1; ip>=piv; ip=ip-IDB_RECLEN-1) { + call amovc (Memc[ip], Memc[ip+IDB_RECLEN+1], IDB_RECLEN) + } + } + Memc[ua+curlen+IDB_RECLEN]='\n' + Memc[ua+curlen+IDB_RECLEN+1]=EOS + + # Form a card with keyword name and placeholder for value. + call sprintf (card, IDB_RECLEN+10, "%-8s= %s%*t\n") + call pargstr (Memc[keyname]) + if (datatype[1] == 'c') { + call pargstr ("' '") + call pargi (IDB_LENSTRINGRECORD + 1) + } else { + call pargstr ("") + call pargi (IDB_LENNUMERICRECORD + 1) + } + + # Replace keyword at the position rp+81. + if (baf == AFTER) + call amovc (card, Memc[rp+IDB_RECLEN+1], IDB_RECLEN) + else + call amovc (card, Memc[rp], IDB_RECLEN) + +#for (ip=1; ip<5; ip=ip+1) { +#call eprintf("<%40.40s>\n") +# call pargstr(Memc[rp-(2-ip)*(IDB_RECLEN+1)]) +#} + call sfree (sp) +end diff --git a/sys/imio/dbc/impcom.x b/sys/imio/dbc/impcom.x new file mode 100644 index 00000000..b110536e --- /dev/null +++ b/sys/imio/dbc/impcom.x @@ -0,0 +1,97 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include "idbc.h" + +# IMPCOM -- Change the comment field for a keyword. + +procedure impcom (im, key, comment) + +pointer im #I image descriptor +char key[ARB] #I parameter to be set +char comment[ARB] #I comment string + +bool string_valued +int ch, i, ti, j +pointer rp, ip, op, sp, val, start, text, cmmt +int idb_findrecord() +errchk syserrs + +begin + call smark (sp) + call salloc (val, SZ_LINE, TY_CHAR) + call salloc (text, SZ_LINE, TY_CHAR) + call salloc (cmmt, SZ_LINE, TY_CHAR) + + # Find the record. + if (idb_findrecord (im, key, rp) == 0) + call syserrs (SYS_IDBKEYNF, key) + + # Determine the actual datatype of the parameter. String valued + # parameters will have an apostrophe in the first nonblank column + # of the value field. + + string_valued = false + ti = text + for (ip=IDB_STARTVALUE; ip <= IDB_ENDVALUE; ip=ip+1) { + # Skip leading whitespace. + for (; Memc[rp+ip-1] == ' '; ip=ip+1) { + Memc[ti] = Memc[rp+ip-1] + ti = ti + 1 + } + if (Memc[rp+ip-1] == '\'') { + # Get string value. + Memc[ti] = Memc[rp+ip-1] + ti = ti + 1 + do i = ip, IDB_RECLEN { + ch = Memc[rp+i] + Memc[ti] = ch + ti = ti + 1 + if (ch == '\n') + break + if (ch == '\'') + break + } + do j = i, IDB_ENDVALUE-2 { + Memc[ti] = ' ' ; ti=ti+1 + } + break + + } else { + # Skip numeric value. + do i = ip, IDB_RECLEN { + ch = Memc[rp+i-1] + Memc[ti] = ch + ti = ti + 1 + if (ch == '\n' || ch == ' ' || ch == '/') + break + } + if (ch == ' ') + ti = ti - 1 + do j = i, IDB_ENDVALUE { + Memc[ti] = ' ' ; ti=ti+1 + } + break + } + } + Memc[ti]=EOS + if (comment[1] != EOS) { + call strcat (" / ", Memc[ti], SZ_LINE) + for (i=1; comment[i] == ' '; i=i+1) + ; + call strcat (comment[i], Memc[ti], SZ_LINE) + } else { + do j = i, IDB_RECLEN { + Memc[ti] = ' ' ; ti=ti+1 + } + } + # Update the parameter value. + op = rp + IDB_STARTVALUE + ti-text - 1 + start = op + for (ip=ti; Memc[ip] != EOS && Memc[op] != '\n'; ip=ip+1) { + Memc[op] = Memc[ip] + op = op + 1 + } + + call sfree (sp) +end diff --git a/sys/imio/dbc/impkbc.x b/sys/imio/dbc/impkbc.x new file mode 100644 index 00000000..fb28eacd --- /dev/null +++ b/sys/imio/dbc/impkbc.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMPKBC -- Put an image header parameter of type boolean. + +procedure impkbc (im, key, bval, comment) + +pointer im # image descriptor +char key[ARB] # parameter to be set +bool bval # parameter value +char comment[ARB] # +char sval[2] + +begin + if (bval) + sval[1] = 'T' + else + sval[1] = 'F' + sval[2] = EOS + + call impstrc (im, key, sval, comment) +end diff --git a/sys/imio/dbc/impkdc.x b/sys/imio/dbc/impkdc.x new file mode 100644 index 00000000..6eb671f3 --- /dev/null +++ b/sys/imio/dbc/impkdc.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# IMPKDDC -- Put an image header parameter of type double. + +procedure impkdc (im, key, dval, comment) + +pointer im # image descriptor +char key[ARB] # parameter to be set +double dval # double precision value +char comment[ARB] # + +pointer sp, sval +int i, strlen() + +begin + call smark (sp) + call salloc (sval, SZ_FNAME, TY_CHAR) + + # Reduce the precision of the encoded value if necessary to fit in + # the FITS value field. Start with NDIGITS_DP-1 as the precision + # estimate NDIGITS_DP is only approximate, and if we make up half a + # digit of precision the result can be 1.00000000000000001 instead + # of 1.0. + + for (i=NDIGITS_DP-1; i >= NDIGITS_RP; i=i-1) { + call sprintf (Memc[sval], SZ_FNAME, "%0.*g") + call pargi (i) + call pargd (dval) + if (strlen (Memc[sval]) < 20) + break + } + + # Write the new value to the header. + call impstrc (im, key, Memc[sval], comment) + + call sfree (sp) +end diff --git a/sys/imio/dbc/impkic.x b/sys/imio/dbc/impkic.x new file mode 100644 index 00000000..3acb0fbd --- /dev/null +++ b/sys/imio/dbc/impkic.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMPKIC -- Put an image header parameter of type integer. + +procedure impkic (im, key, ival, comment) + +pointer im # image descriptor +char key[ARB] # parameter to be set +int ival # parameter value +char comment[ARB] # +pointer sp, sval + +begin + call smark (sp) + call salloc (sval, SZ_FNAME, TY_CHAR) + + call sprintf (Memc[sval], SZ_FNAME, "%d") + call pargi (ival) + call impstrc (im, key, Memc[sval], comment) + + call sfree (sp) +end diff --git a/sys/imio/dbc/impklc.x b/sys/imio/dbc/impklc.x new file mode 100644 index 00000000..7ef227ff --- /dev/null +++ b/sys/imio/dbc/impklc.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMPKLC -- Put an image header parameter of type long integer. + +procedure impklc (im, key, lval, comment) + +pointer im # image descriptor +char key[ARB] # parameter to be set +long lval # parameter value +char comment[ARB] # +pointer sp, sval + +begin + call smark (sp) + call salloc (sval, SZ_FNAME, TY_CHAR) + + call sprintf (Memc[sval], SZ_FNAME, "%d") + call pargl (lval) + call impstrc (im, key, Memc[sval], comment) + + call sfree (sp) +end diff --git a/sys/imio/dbc/impkrc.x b/sys/imio/dbc/impkrc.x new file mode 100644 index 00000000..1f1459dd --- /dev/null +++ b/sys/imio/dbc/impkrc.x @@ -0,0 +1,25 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +# IMPKRC -- Put an image header parameter of type real. + +procedure impkrc (im, key, rval, comment) + +pointer im # image descriptor +char key[ARB] # parameter to be set +real rval # parameter value +char comment[ARB] # +pointer sp, sval + +begin + call smark (sp) + call salloc (sval, SZ_FNAME, TY_CHAR) + + call sprintf (Memc[sval], SZ_FNAME, "%0.*g") + call pargi (NDIGITS_RP) + call pargr (rval) + call impstrc (im, key, Memc[sval], comment) + + call sfree (sp) +end diff --git a/sys/imio/dbc/impksc.x b/sys/imio/dbc/impksc.x new file mode 100644 index 00000000..0a74d0f0 --- /dev/null +++ b/sys/imio/dbc/impksc.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMPKSC -- Put an image header parameter of type short integer. + +procedure impksc (im, key, value, comment) + +pointer im # image descriptor +char key[ARB] # parameter to be set +short value # parameter value +char comment[ARB] # +pointer sp, sval + +begin + call smark (sp) + call salloc (sval, SZ_FNAME, TY_CHAR) + + call sprintf (Memc[sval], SZ_FNAME, "%d") + call pargs (value) + call impstrc (im, key, Memc[sval], comment) + + call sfree (sp) +end diff --git a/sys/imio/dbc/impstrc.x b/sys/imio/dbc/impstrc.x new file mode 100644 index 00000000..0a11782e --- /dev/null +++ b/sys/imio/dbc/impstrc.x @@ -0,0 +1,117 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include "idbc.h" + +# IMPSTRC -- Put an image header parameter of type string. If the named +# parameter is a standard parameter of type other than string, decode the +# string and set the binary value of the parameter. If the parameter is +# a nonstandard one we can do a simple string edit, since user parameters +# are stored in the user area in string form. The datatype of the parameter +# must be preserved by the edit, i.e., parameters of actual datatype string +# must be quoted and left justified and other parameters must be unquoted +# and right justified in the value field. + +procedure impstrc (im, key, value, comment) + +pointer im #I image descriptor +char key[ARB] #I parameter to be set +char value[ARB] #I new parameter value +char comment[ARB] #I comment string + +bool string_valued +int nchars, ch, i +pointer rp, ip, op, sp, val, start, text, cmmt, slen +int idb_putstring(), idb_findrecord(), idb_filstr(), strlen() +errchk syserrs + +begin + call smark (sp) + call salloc (val, SZ_LINE, TY_CHAR) + call salloc (text, SZ_LINE, TY_CHAR) + call salloc (cmmt, SZ_LINE, TY_CHAR) + + # Filter the value string to remove any undesirable characters. + nchars = idb_filstr (value, Memc[text], SZ_LINE) + + # Check for a standard header parameter first. + if (idb_putstring (im, key, Memc[text]) != ERR) { + call sfree (sp) + return + } + + # Find the record. + if (idb_findrecord (im, key, rp) == 0) + call syserrs (SYS_IDBKEYNF, key) + + # Determine the actual datatype of the parameter. String valued + # parameters will have an apostrophe in the first nonblank column + # of the value field. Skip the value and treat the rest of + # the line as a comment to be preserved. + + string_valued = false + for (ip=IDB_STARTVALUE; ip <= IDB_ENDVALUE; ip=ip+1) { + # Skip leading whitespace. + for (; Memc[rp+ip-1] == ' '; ip=ip+1) + ; + + if (Memc[rp+ip-1] == '\'') { + # Skip string value. + do i = ip, IDB_RECLEN { + ch = Memc[rp+i] + if (ch == '\n') + break + Memc[rp+i] = ' ' + if (ch == '\'') + break + } + + string_valued = true + break + + } else { + # Skip numeric value. + do i = ip, IDB_RECLEN { + ch = Memc[rp+i-1] + if (ch == '\n' || ch == ' ' || ch == '/') + break + Memc[rp+i-1] = ' ' + } + break + } + } + + # Skip whitespace before any comment. + for (ip = i; Memc[rp+ip-1] == ' '; ip=ip+1) + ; + + call strcpy (" / ", Memc[cmmt], IDB_RECLEN) + call strcat (comment, Memc[cmmt], IDB_RECLEN) + + # Put enough blanks to erase the old comment. + slen = strlen(Memc[cmmt]) + for (i=slen+1; i<=71-slen; i=i+1) + Memc[cmmt+i-1] = ' ' + Memc[cmmt+i-1] = EOS + + # Encode the new value of the parameter. + if (string_valued) { + call sprintf (Memc[val], SZ_LINE, " '%-0.68s%11t'%22t%-0.68s") + call pargstr (Memc[text]) + call pargstr (Memc[cmmt]) + } else { + call sprintf (Memc[val], SZ_LINE, "%21s%-0.68s") + call pargstr (Memc[text]) + call pargstr (Memc[cmmt]) + } + + # Update the parameter value. + op = rp + IDB_STARTVALUE - 1 + start = op + for (ip=val; Memc[ip] != EOS && Memc[op] != '\n'; ip=ip+1) { + Memc[op] = Memc[ip] + op = op + 1 + } + + call sfree (sp) +end diff --git a/sys/imio/dbc/imputextf.x b/sys/imio/dbc/imputextf.x new file mode 100644 index 00000000..151f13e4 --- /dev/null +++ b/sys/imio/dbc/imputextf.x @@ -0,0 +1,185 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <ctype.h> +include <imhdr.h> +include <imio.h> +include "idbc.h" + +define LEN_HISTSTR 71 # length of a history string on a FITS card +define CLEN 81 + +# IMPUTXTF -- Insert a text file in the user area with HISTORY card. +# The file cannot have control characters in it; only the FITS standard +# character set is supported. The text is broken in records long enough +# to fit words; i.e. it tries not to split words. The file can have +# imbedded tabs and they will be expanded. + +procedure imputextf (im, file, pkey, baf) + +pointer im #I image descriptor +char file[ARB] #I the text file to be inserted and appended +char pkey[ARB] #I Pivot keyword to insert 'key' +int baf #I Insert BEFORE or AFTER + +pointer ua, rp, piv, ip, op +int max_lenuserarea, curlen, buflen, jump, nlines +int old_curlen, k, nshift +char blk + +int strlen(), idb_findrecord() +errchk syserrs + +begin + # FITS format requires that the keyword name be upper case. + + ua = IM_USERAREA(im) + curlen = strlen (Memc[ua]) + buflen = LEN_IMDES + IM_LENHDRMEM(im) + max_lenuserarea = (buflen - IMU) * SZ_STRUCT - 1 + + # Determine the number of lines before inserting into the UA + call imrartxt (ua, file, nlines, NO) + + old_curlen=curlen + curlen = curlen + nlines*CLEN + if (curlen+81 >= max_lenuserarea) { + IM_HDRLEN(im) = LEN_IMHDR + + (curlen + 10*36*CLEN + SZ_STRUCT-1) / SZ_STRUCT + IM_LENHDRMEM(im) = IM_HDRLEN(im) + (SZ_UAPAD / SZ_STRUCT) + call realloc (im, IM_LENHDRMEM(im) + LEN_IMDES, TY_STRUCT) + buflen = LEN_IMDES + IM_LENHDRMEM(im) + max_lenuserarea = (buflen - IMU) * SZ_STRUCT - 1 + ua = IM_USERAREA(im) + } + + blk=' ' + # Find pivot keyword + if (idb_findrecord (im, pkey, rp) == 0) { + # Keyw not found. Append the new keywords. + piv = ua + old_curlen + } else { + # Shift cards after or before pivot. + if (baf == AFTER) + piv = rp + CLEN + else + piv = rp + + jump=nlines*CLEN + + # Shift cards down from the pivot point. + nshift = (ua+old_curlen - piv)/CLEN + ip = ua + old_curlen + do k = 1, nshift { + ip = ip - CLEN + op = jump + ip + call amovc (Memc[ip], Memc[op], CLEN) + } + } + + # Append the HISTORY records to the user area. + call imrartxt (piv, file, nlines, YES) + +end + + +# IMRARTXT -- Internal routines to count the number of lines transfered to the +# UA as HISTORY records. + +procedure imrartxt (piv, fname, nlines, insert) + +pointer piv #I UA address to start inserting kw +char fname[ARB] +int nlines +int insert + +char line[IDB_RECLEN+1], blk, lf +pointer sp, ln, buf, urp +int ip, op, fd, in_last_blank, out_last_blank, blen, len, w, k +int save_ip +int open(), getline(), strlen() + +begin + call smark(sp) + call salloc (ln, SZ_LINE, TY_CHAR) + call salloc (buf, SZ_LINE, TY_CHAR) + + fd = open(fname, READ_ONLY, TEXT_FILE) + nlines= 0 + blk=' ' + lf='\12' + call strcpy ("HISTORY ", Memc[buf], 9) + Memc[buf+IDB_LENSTRINGRECORD]='\n' + Memc[buf+IDB_LENSTRINGRECORD+1]=EOS + urp = piv + while(getline(fd, Memc[ln]) != EOF) { + for (ip=1; Memc[ln+ip-1] != EOS; ) { + # If no blanks are found in HISTORY string, make sure + # all of it gets output anyway. + + in_last_blank = ip + LEN_HISTSTR - 1 + out_last_blank = LEN_HISTSTR + + # Copy the string to the output buffer, marking the + # last blank found. + + for (op=1; op <= LEN_HISTSTR; op=op+1) { + if (Memc[ln+ip-1] == lf) { + ip=ip+1 + } + if (IS_WHITE (Memc[ln+ip-1])) { + # Detab input text. + if (Memc[ln+ip-1] == '\t') { + if(ip-save_ip == 1) + w=8 + else + w=9-op+(op/9)*8 + for(k=0;k<w;k=k+1) { + line[op+k] = blk + } + save_ip=ip + op = op + w - 1 + ip = ip + 1 + in_last_blank = ip + out_last_blank = op + next + } + in_last_blank = ip + out_last_blank = op + } else if (Memc[ln+ip-1] == EOS) + break + line[op] = Memc[ln+ip-1] + ip = ip + 1 + } + # The output string is full; close it off properly + # and get ready for the next round (if any). + line[op] = EOS + if (Memc[ln+ip-1] != EOS) { + # Break at last word boundary if in a word. + if (!IS_WHITE (Memc[ln+ip-1])) { + line[out_last_blank+1] = EOS + ip = in_last_blank + 1 + } + + # Skip leading whitespace on next line. + while (IS_WHITE(Memc[ln+ip-1])) + ip = ip + 1 + } + nlines = nlines + 1 + + if (insert == YES) { + # Write out the FITS HISTORY card. + len = strlen(line) + blen = IDB_LENSTRINGRECORD - len - 9 + call amovc (line, Memc[buf+9], len) + call amovkc (blk, Memc[buf+9+len], blen) + + call amovc (Memc[buf], Memc[urp], IDB_RECLEN+1) + urp = urp + IDB_RECLEN + 1 + } + } + } + + call close(fd) + call sfree(sp) +end diff --git a/sys/imio/dbc/imputhi.x b/sys/imio/dbc/imputhi.x new file mode 100644 index 00000000..0d1de5a9 --- /dev/null +++ b/sys/imio/dbc/imputhi.x @@ -0,0 +1,113 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <fset.h> +include <imhdr.h> +include <imio.h> +include "idbc.h" + +# IMPHIS -- Insert a user field in the image header after the specified +# keyword. It is an error if the named field already exists. + +procedure imphis (im, key, text, pkey, baf) + +pointer im #I image descriptor +char key[ARB] #I name of the new parameter +char text[ARB] #I the history string to be added +char pkey[ARB] #I 'key' will be inserted bef/after pkey +int baf # I Insert BEFORE or AFTER + +pointer rp, sp, keyname, ua, ip, instr +int max_lenuserarea, curlen, buflen, nchars, piv +int idb_findrecord() +bool streq() +int strlen(), idb_filstr(), nowhite() +char card[IDB_RECLEN+1] +errchk syserrs, sprintf, pargstr, pargi + +begin + call smark (sp) + call salloc (keyname, SZ_FNAME, TY_CHAR) + call salloc (instr, SZ_LINE, TY_CHAR) + + nchars = idb_filstr (key, Memc[keyname], IDB_SZFITSKEY) + nchars = nowhite (Memc[keyname], Memc[keyname], IDB_SZFITSKEY) + call strupr (Memc[keyname]) + + # Only standard FITS HISTORY keywords are allowed. + if (!(streq(Memc[keyname],"HISTORY") || + streq(Memc[keyname],"COMMENT") || + streq(Memc[keyname],"ADD_BLAN"))) { + call sfree (sp) + return + } + + if (streq(Memc[keyname],"ADD_BLAN")) { + call strcpy (" ", Memc[keyname], SZ_FNAME) + } + + # Open the user area string for appending. 'buflen' is the malloc-ed + # buffer length in struct units; IMU is the struct offset to the user + # area, i.e., the size of that part of the image descriptor preceding + # the user area. + + ua = IM_USERAREA(im) + curlen = strlen (Memc[ua]) + buflen = LEN_IMDES + IM_LENHDRMEM(im) + max_lenuserarea = (buflen - IMU) * SZ_STRUCT - 1 + + if (curlen+81 >= max_lenuserarea) { + IM_HDRLEN(im) = LEN_IMHDR + + (curlen + 10*36*81 + SZ_STRUCT-1) / SZ_STRUCT + IM_LENHDRMEM(im) = IM_HDRLEN(im) + (SZ_UAPAD / SZ_STRUCT) + call realloc (im, IM_LENHDRMEM(im) + LEN_IMDES, TY_STRUCT) + buflen = LEN_IMDES + IM_LENHDRMEM(im) + max_lenuserarea = (buflen - IMU) * SZ_STRUCT - 1 + } + + # If the user area is not empty the last character must be the newline + # record delimiter, else the new record we add will be invalid. + + if (curlen > 0 && Memc[ua+curlen-1] != '\n') + if (curlen >= max_lenuserarea) { + call syserrs (SYS_IDBOVFL, key) + } else { + Memc[ua+curlen] = '\n' + curlen = curlen + 1 + Memc[ua+curlen] = EOS + } + + # Find keyw_after + if (idb_findrecord (im, pkey, rp) == 0) { + # Keyw not found. Append the new keyword. + rp = ua+curlen + baf = BEFORE + } else { + # Shift cards after pivot or before pivot + if (baf == AFTER) + piv = rp + else + piv = rp - IDB_RECLEN - 1 + for (ip= ua+curlen-IDB_RECLEN-1; ip>=piv; ip=ip-IDB_RECLEN-1) { + call amovc (Memc[ip], Memc[ip+IDB_RECLEN+1], IDB_RECLEN) + } + } + Memc[ua+curlen+IDB_RECLEN]='\n' + Memc[ua+curlen+IDB_RECLEN+1]=EOS + + # Filter the input string to remove any undesirable characters. + nchars = idb_filstr (text, Memc[instr], SZ_LINE) + + # Form a card with keyword name and placeholder for value. + call sprintf (card, IDB_RECLEN+10, "%-8s %-71s\n") + call pargstr (Memc[keyname]) + call pargstr (Memc[instr]) + + # Replace keyword at the position rp+81. + if (baf == AFTER) + call amovc (card, Memc[rp+IDB_RECLEN+1], IDB_RECLEN) + else + call amovc (card, Memc[rp], IDB_RECLEN) + + call sfree (sp) +end diff --git a/sys/imio/dbc/mkpkg b/sys/imio/dbc/mkpkg new file mode 100644 index 00000000..1997f6b6 --- /dev/null +++ b/sys/imio/dbc/mkpkg @@ -0,0 +1,36 @@ +# Update the image header database interface. + +$checkout libex.a lib$ +$update libex.a +$checkin libex.a lib$ +$exit + +libex.a: + imakbc.x + imakbci.x + imakdc.x + imakdci.x + imakic.x + imakici.x + imaklc.x + imaklci.x + imakrc.x + imakrci.x + imaksc.x + imaksci.x + imastrc.x + imastrci.x + imgcom.x idbc.h <ctype.h> + iminfi.x idbc.h <fset.h> <imhdr.h> <imio.h> + impcom.x idbc.h + impkbc.x + impkdc.x <mach.h> + impkic.x + impklc.x + impkrc.x <mach.h> + impksc.x + imdrmcom.x idbc.h + impstrc.x idbc.h + imputextf.x idbc.h <ctype.h> <imhdr.h> <imio.h> + imputhi.x idbc.h <fset.h> <imhdr.h> <imio.h> + ; diff --git a/sys/imio/doc/IMH.hlp b/sys/imio/doc/IMH.hlp new file mode 100644 index 00000000..0599843b --- /dev/null +++ b/sys/imio/doc/IMH.hlp @@ -0,0 +1,219 @@ +.help imio Mar86 "Image I/O Modifications" +.ce +\fBImage I/O Modifications to Support Multiple Data Formats\fR +.ce +Doug Tody +.ce +March 16, 1986 + +.nh +Introduction + + The primary purpose of this revision of IMIO was to add support for +multiple disk data formats. This was done by defining a new interface +called IMH, which hides the details of how images are stored on disk from +the IMIO code. IMIO is concerned only with image i/o based on an internal +image descriptor. IMIO calls IMH to perform all imagefile management +operations, but accesses the pixel data directly using the FIO interface. +The IMH interface initially supports only the old IRAF and SDAS image formats, +but may be extended to support other formats in the future if necessary. +The IMH interface should be reusable in the future when IMIO is layered +upon DBIO. + +A secondary purpose of this revision was to make several minor enhancements +to IMIO to better support groups of images. The image template syntax +has been extended to provide a special selection syntax for specifying the +subset of the images in a group or set of groups to be operated upon. +Minor changes were made to the filenames of the files used to store IRAF +format images to make identification of the header and pixel files easier. +The image database interface (IDB) has been extended to permit the storage +of one dimensional arrays in the image header. IMIO was modified to use the +static file driver rather than the regular binary file driver to access +pixel data. + +.nh +Image Templates +.nh 2 +Image Template Syntax + + An image template is an expression used to specify the set or group of +images to be operated upon. The current image template syntax is upwards +compatible with the planned DBIO record select/project syntax. The full +syntax is as follows. + + images [,images ...] + +where \fIimages\fR is an expression built up from some combination of the +following constructs: + +.nf + @listfile take strings from a listfile + pattern expand pattern against database + str // str concatenate strings + {select} select elements from a set + [section] append image section +.fi + + +These elements may appear in any order, although not all orderings make +sense. The \fIpattern\fR string may contain any of the standard pattern +matching characters, but the pattern matching meta-characters {} (ignore +case) and [] (character class) must be escaped to avoid interpretation as +the subset selection and image section operators. An \fIimages\fR string +may contain at most one list construct, i.e., listfile reference, pattern, +or selection set. The \fIselect\fR expression is limited to a range list +at present. The range list syntax uses the : range syntax, i.e., +"from[:to[:by]]". Some examples are given below. None of templates shown +in these examples need be quoted if entered in the CL command mode. + + +.nf + pix one image + pix.0013 one image + @pics list of images + pix[*,-*] one image section + @pics[*,-*] list of image sections + pix.* all pix.whatever images in cwd + pix.*//.flat same, but append ".flat" to image name + pix.*//.flat[*,5] same, but append image section too + pix{1,4,9:21} pix.0001, pix.0004, and 9 through 21 + pix{1,4,9:21}[1:10,5] same, but append section to each one +.fi + + +Note that \fIselect\fR expressions are expanded without checking to see if the +named images actually exist. Image names are formed by concatenating the +image number encoded as a four digit string, padding with zeroes at the left +as in the examples. + +.nh 2 +Image Template Procedures + + The image template package (IMT) is an existing package. The calling +sequences are identical to those of the FNT (FIO filename template) package +and have not been changed in this release of the package. Extensive changes +have however been made internally, and the new package has been installed +in IMIO. The old package has been removed from the XTOOLS library. To use +the new version of the package, all one need do is relink. + + +.ks +.nf + list = imtopen (template) + nimages = imtlen (list) + imtrew (list) + nchars|EOF = imtgetim (list, fname, maxch) + imtclose (list) +.fi +.ke + + +An image template is expanded into a list of image names or image sections +with \fBimtopen\fR. The list is not globally sorted, however sublists +generated by pattern matching are sorted before appending the sublist to +the final list. The number of images or image sections in a list is given by +\fBimtlen\fR. Images are read sequentially from the list with \fBimtgetim\fR, +which returns EOF when the end of the list is reached. The list may be +rewound with \fBimtrew\fR. An image template list should be closed with +\fBimtclose\fR to return the buffers used to store the list and its +descriptor. + +.nh +The Image Header Access Interface (IMH) + + The image header access interface (IMH) is a new interface in this release +of IMIO. The purposes of the IMH interface are to hide knowledge of how images +are stored on disk from the rest of the system, and to make it possible to +support multiple image storage formats. IMIO is not aware that there are +multiple image storage formats. When called to open an existing image, +IMH determines the image format and calls the appropriate lower level access +procedure to read the image header. A standard set of IMH callable interface +procedures are required for each supported storage format. + +The IMH package is intended as an internal IMIO package and should not normally +be called by packages other than IMIO. + + +.ks +.nf + im = imh_open (image, acmode, o_im) # open/create header + imh_opix (im, acmode) # open/create pixels + imh_update (im) # update header + imh_close (im) # close image + + y/n = imh_access (image, type) # test if image exists + imh_delete (image) # delete an image + imh_rename (oldname, newname) # rename an image + imh_copy (oldname, newname) # copy an image +.fi +.ke + + +The \fIimh_open\fR procedure will open an existing image, create a new +image, or make a new copy of an existing image (preserving the header +of the old image but not the pixels). A pointer to an IMIO binary image +descriptor is returned; when opening an existing image, the primary +function of \fIimh_open\fR is to map the disk image header, stored in +whatever format, into the IMIO fixed format binary descriptor. + +The \fIimh_opix\fR procedure must be called after the header has been opened +before any pixel i/o can be done to the image. In the case of a new image +the size attributes of the new image are not fixed until \fIimh_opix\fR is +called (giving the high level code time to set the size parameters in the +image descriptor). It is not necessary to call \fIimh_opix\fR if only the +header of an existing image is to be accessed. + +The \fIimh_access\fR procedure is provided to test if the named image +exists (no test is made to determine if the image is also accessible). +An integer code identifying the storage format of the image, e.g., old +IRAF or SDAS, is returned in the \fItype\fR argument. Currently, the type +of an image is indicated by the filename extension of the header file. + +The \fIimh_rename\fR and \fIimh_copy\fR procedures are in principle not +required since the operations can be performed at a high level with the +procedures already provided, but the IMH operators can carry out the +operations more efficiently and without the possibility of information being +lost, since they have knowledge of the physical storage format. + +.nh +Physical Data Formats + + The only two physical (disk) data formats currently supported are the +old IRAF format and the STScI SDAS format. The IMH interface makes it +relatively straightforward for other sites to interface their local format +if necessary, or to support multiple versions of the same format. + +IMH will automatically read images stored in any of the supported formats. +When making a NEW_COPY image, IMH will generate a new image in the same +format as the existing input image. When making a NEW_IMAGE type image, +the value of the environment variable \fBimtype\fR determines the type of +image to be created. The recognized values of \fBimtype\fR are shown below. + +.ks +.nf + not defined old iraf format + imtype = "oiraf" old iraf format + imtype = "sdas" SDAS/SOGS format +.fi +.ke + +The format in which an image is stored is indicated by the filename extension +of the header file. The filename extension is not specified in image names +or templates above the IMH interface, but is visible to the user in a +directory listing. + +.ks +.nf + .imh old iraf format header + .hhh SDAS/SOGS format header +.fi +.ke + +The current IMH interface is implemented in such a way that the semantics +of the two image storage formats are essentially equivalent, i.e., applications +programs should work consistently regardless of the storage format used. +In order to achieve this, the SDAS group format is fully supported only +when reading existing group format images. On output, images stored in +SDAS format are stored in separate files (gcount=1). The IRAF image template +is more flexible than the SDAS group format, simplifies programming, and +provides much the same basic capability. diff --git a/sys/imio/doc/Notes b/sys/imio/doc/Notes new file mode 100644 index 00000000..b7f6675c --- /dev/null +++ b/sys/imio/doc/Notes @@ -0,0 +1,177 @@ +IMIO modifications to support SDAS format imagefiles +---------------------------------------------------------------- + +1. EXISTING DATA FORMATS + + +1.1 IRAF Data Format (pre-DBIO) + +Characteristics: + + o Header: binary data structure + fits card image string buffer + o Pixels: binary pixhdr + pixels (can be block aligned) + o Many datatypes supported + o One image per imagefile + o Pixel file may be stored in different directory than header file + o Header file is protected from deletion + +Disadvantages: + + o Can lose track of pixel file if header is deleted. + o Since each image is stored in a separate pair of files, + directories can be large. + o The storage format is machine dependent. + +Modifications in this release: + + o Add .imh extension to image header file + o Add .pix extension to pixel file, make root name same as that + of the header file + o If IMDIR = "", put pixel file in same directory as the header. + This avoids use a pathname in the header, hence the images + are relocatable, but forces one to work on a scratch device. + + + +1.2 SDAS Data Format + +Characteristics: + + o Images are physically stored in group format + o FITS group header + binary image headers + o Pixfile format: [pixels + group header] * ngroups + nothing is aligned on block boundaries + o Pixel and header files stored in same directory + o Header file extension .hhh, pixel file extension .hhd + +Disadvantages: + + o Images cannot be added to a group; the number of images in a + group must be specified when the group is created. + o The individual images in a group cannot be deleted; only the + entire group can be deleted. + o The format of the image headers for the individual images in + a group is fixed at create time; new parameters cannot be + added to the individual image headers (new parameters can + however be added which apply to the group as a whole). + o The images in a group must all be of the same size and datatype + (this is probably not a serious disadvantage). + o The storage format is machine dependent. + + +2. IMAGEFILE ACCESS + + o Open/create image + o Make new_copy image + o Access pixel segment + o Close image + o Test if image exists (and determine type) + o Delete image + o Rename image + + +2.1 Open Image + + generate header filename + open/create header file + allocate image descriptor + if (existing image) + read image header into descriptor + else + initialize descriptor + return pointer to descriptor + + +2.2 Access Pixel Segment + + All image size parameters must be determined at pixfile creation + time. + + if (new segment) { + fill in descriptor + if (new pixel file) + allocate pixel file + else + open pixel file r/w + update header + } else + open pixel file + + +2.3 Close Image + + if (header has been modified) + update header + close pixfile + close header + + + +3. SPECIFICATIONS + +3.1 Image Header Access + + To minimize changes to existing code, the IMIO internal data structures +will not be modified. The principal change to the structure of the existing +interface is the replacement of the direct calls to the FIO open, close, read, +write, etc. procedures called to access the image header in mass storage by +calls to a new interface IH (Image Header access). The new interface will +hide the disk image format from IMIO. Interface subroutines will be provided +only for the IRAF and SDAS image formats, although in principle the interface +will be extensible to other formats as well. + +Ideally the IH interface should be coded using only relatively low level +VOS and kernel facilities (i.e., no high level FIO, no error handling) so that +it may be used by the IMFORT interface and called from host Fortran programs, +as well as by IMIO. + + + im = ihopen (image, group, acmode) + ihopix (im) + ihclose (im) + + +IHOPEN returns the standard IMIO image descriptor, consisting of the internal +IMIO fields, the binary image header structure IMHDR, and the "user area", +a sequence of FITS card images stored in memory a string buffer, i.e., +each card image is represented as a stripped, newline delimited sequence of +characters, with an EOS following the last card. + +The GROUP argument to IHOPEN permits access to the individual elements of +a group format imagefile. Group format is supported for both imagefile +formats, the principal difference being that the individual images are +stored in separate files in the old IRAF format, and in a single pair of +images in the SDAS format. + +The individual images in a group format imagefile appear as separate, +independent images in IMIO. Several images in a group format imagefile may +be simultaneously open (the files are physically opened only once). +The group header parameters are duplicated for each image in the group. +If the images are stored in the old IRAF format on disk the values of these +parameters may vary from image to image, otherwise (SDAS format) they are +the same for all members of the group. The number of images in a group is +fixed at image creation time. + + +3.2 Image Sections and Templates + + The image section notation recognized by IMMAP may include a group +specifier (set selection expression) as well as a section specifier. +The full syntax is "image{group}[section]", e.g., + + pix{3}[*,5] + +where { is the set selection operator, and [ is the familiar array subscript +or subsection operator. + +The image template notation has also been generalized to support group format +image data. The general form of a template element is + + image{groups}[section] + +where [section] applies to each image in the group. For example, the template + + aa{4},bb{1,3:5},cc{12:15}[*,-*] + +expands as image 4 of group AA, images 1, 3, 4, and 5 of group BB, and images +12 through 15 of group CC flipped in Y. diff --git a/sys/imio/doc/bench.ms b/sys/imio/doc/bench.ms new file mode 100644 index 00000000..05717208 --- /dev/null +++ b/sys/imio/doc/bench.ms @@ -0,0 +1,73 @@ +.OM +.TO +Steve Ridgway +.FR +Doug Tody +.SU +Performance of IRAF Image I/O +.PP +As Caty reported in her memo of 15 November, the timings of the \fIimarith\fR +task were surprisingly poor, i.e., approximately 20 cpu seconds for the +addition of two 200 column by 800 line short integer images, producing a +short integer image as output (a "short" integer is 16 bits). +A look at the code for \fIimarith\fR revealed +that the internal computations were being done in double precision floating, +regardless of the datatype of the images on disk. +I was not aware of this and I appreciate having it brought to my attention. +Fixing \fIimarith\fR took several hours and nearly cut the timings in half. +.PP +When I orginally implemented IMIO I planned to eventually make three major +optimizations (as noted in the program plan and system interface reference +manual): +.RS +.LP \(bu +Optimize the special case of line by line i/o with no automatic type +conversion, image sectioning, boundary extension, etc. +.LP \(bu +Provide direct access into the FIO file buffers when possible to eliminate +the memory to memory copy to and from the IMIO and FIO buffers. +.LP \(bu +Implement a optimal static file driver for UNIX to eliminate the overhead +of copying the data through the system buffer cache, and to permit +overlapped i/o. +.RE +.LP +I have gone ahead and implemented the first two optimizations; this took +a day and the changes were entirely internal to the interface, +requiring no changes to user code and no loss of machine independence. +After these changes were made to IMIO I ran several benchmarks with the +following results. All benchmarks were for images with 16 bit integer pixels. +.TS +center box tab(|); +ci ci ci ci ci ci ci +r n n n nb n n. +operation|open/close|line ovhead|kernel op|total user time|%opt|systime +- +(c=a+b)[200,800]|.38|1.43|1.69|3.50|48%|3.82 +(c=a+b)[800,800]|.38|1.43|6.94|8.75|79%|12.16 +minmax[800,800]|.05|0.59|11.39|12.03|95%|2.66 +.TE +.PP +The columns in the table show the operation tested by the benchmark (two image +additions, each involving three images, and a computation of the minimum and +maximum of a single image), the overhead involved in opening and closing the +images (same operation on a [1,1] image), the total overhead to process the +image lines, the time consumed by the kernel operation, the total user time +for the task, the degree of optimality (ratio of time spent in the kernel +vector operation to the total time for the task), +and the system (UNIX kernel) time required. +.PP +In short, the time required by the original benchmark has decreased from +20 seconds to 3.5 seconds, disregarding the system time. In this worst +case benchmark we still manage to come within 48% of the optimal time of +1.69 seconds for a VAX 11/750. +.PP +The short integer vector addition kernel operator was hand optimized in +assembler for these benchmarks to provide a true measure of the degree +of optimality. The actual unoptimized UNIX vector addition operator is +slightly slower. +The last column, labelled "systime", shows the cpu time consumed +by the UNIX kernel moving the pixels to and from disk; this is the time +that will be eliminated by the static file driver optimization. +Once the static file driver is optimized any further optimizations +will be difficult. diff --git a/sys/imio/doc/imfort.doc b/sys/imio/doc/imfort.doc new file mode 100644 index 00000000..6eef0dc6 --- /dev/null +++ b/sys/imio/doc/imfort.doc @@ -0,0 +1,72 @@ +Jun 19: IRAF images may now be read and written from Fortran programs. + The interface is simple and efficient, but limited in capability. + If a more sophisticated interface is required one may call Fortran + subroutines from SPP main programs (templates are available for + accessing 1 and 2 dimensional images in this fashion), or program + directly in SPP. + + 1. Documentation from the source file + + IMFORT -- Fortran interface to IRAF images. This interface permits a + Fortran program to read or write an existing IRAF image. There is + currently no provision for creating new images or deleting old images + from Fortran. The interface routines are as follows: + + im = imopen (image, mode, ndim, len_axes) + imclos (im) + + imget[sr] (im, buf, x1, x2, linenum) + imput[sr] (im, buf, x1, x2, linenum) + + where + input integer im, x1, x2, linenum + input character image, mode + output integer ndim, len_axes(7) + pixel buf(*) + + imgets,imputs are for short integer (integer*2) pixels + imgetr,imputr are for real pixels + + An image must be opened with IMOPEN before it can be accessed. Legal + access modes are 'r', 'w', and 'rw'. The number of dimensions and + the length of the axes are returned in ndim and len_axes; the latter + should be dimensioned for at least 7 dimensions. All coordinates are + 1-indexed. The variable "im" is an integer. The get and put routines + will perform datatype conversion if necessary. The imget and imput + routines will abort program execution if there is an error. + + + 2. Usage + + Source files (minimal documentation in imfort.c header): + + /iraf/sys/imio/mhdr.c.h + /iraf/sys/imio/imfort.c + + Libraries: + + /usr/lib/libiraf.a -liraf on f77 cmd line + /usr/lib/libvops.a -lvops on f77 cmd line + + e.g., + f77 myprog.f -liraf -lvops -o myprog + + or if called in SPP + + cl> xc myprog.x, lib=iraf + + + 3. Example + + integer im + integer axlen(7), ndim + integer imopen + integer*2 pix(1024) + + im = imopen ('/tmp2/iraf/images/m74', 'r', ndim, axlen) + write (*,*) ndim, axlen + call imgets (im, pix, 10,15, 5) + write (*,*) pix(1), pix(5) + stop + end + diff --git a/sys/imio/doc/imio.2.ms b/sys/imio/doc/imio.2.ms new file mode 100644 index 00000000..0727179f --- /dev/null +++ b/sys/imio/doc/imio.2.ms @@ -0,0 +1,331 @@ +.DA May 7, 1985 +.OM +.TO +distribution +.FR +Doug Tody +.SU +New release of image i/o, etc. +.PP +The new release of IMIO has been installed in the system for a week now and +appears to be bug free. This memo summarizes the changes/additions in this +new version of the interface, and introduces the new "image database" tools +\fIhedit\fR and \fIhselect\fR as well. +.NH +Summary of Changes in the Current Release +.PP +The following changes or additions have been made to the IMIO interface and +the \fIimages\fR package. +.RS +.IP \(bu +IMIO now has the ability to perform (optionally) automatic boundary extension +to satisfy out of bounds pixel references. +.IP \(bu +A preliminary database interface has been added to IMIO. +.IP \(bu +Image headers are now variable length and use only the amount of disk space +required to store the header (excluding byte packing). +.IP \(bu +Two new database utility tasks \fIhedit\fR and \fIhselect\fR have been +added to the \fIimages\fR package. Both use the new library subroutine +\fIevexpr\fR, now installed in the FMTIO package. +.IP \(bu +A new task \fIimshift\fR has been added to the \fIimages\fR package to +perform shifts of two dimensional images using full two dimensional +interpolation. The related tasks \fIgeomap\fR and \fIgeotran\fR are +currently being worked on. Some filtering and convolution tasks should +also be available soon. All of these tasks use the new boundary extension +feature of IMIO. +.RE +.PP +The new release of IMIO is upward compatible with previous versions and should +require no changes to or even recompilation of existing code. The basic image +header structure is unchanged hence existing images and image headers are still +accessible. Copying of old images still on disk with \fIimcopy\fR may however +be desirable to reduce disk consumption (the old headers were wasteful of +storage). +.PP +This release of IMIO introduces some database tools and concepts which +should help us understand the role the DBIO interface and DBMS package will +play in image processing applications in the near future. The current database +interface has serious functional limitations and is inefficient for operations +which operate upon entire databases (e.g., the \fIselect\fR operation), +but does provide a basic and much needed image database capability. +.NH +Planned Future Developments +.PP +This new release of IMIO is expected to remain unchanged until DBIO is +completed, at which time a new version of the interface will be released. +This next release is expected to be upward compatible with the current +interface except in cases where the applications task has detailed knowledge +of the current image header structure. Applications which directly access +the "user area" of the current header, or which use certain header fields +such as IM_HISTORY, will have to be modified as these data structures will +change in the next release. +.PP +Applications which use only \fIimmap\fR, \fIimunmap\fR, IM_PIXTYPE, +IM_NDIM, IM_LEN, and the basic i/o procedures should not have to be changed. +The new interface will provide different facilities to do the same things +but we can probably emulate the old interface to allow plenty of time to +convert the old code. Of course, the new interface will provide new facilities +which we did not formerly have and which we will want to use, and therefore +we will eventually have to modify all existing image tasks. +.PP +Perhaps more seriously, we are not going to be able to maintain the ability +to read the existing binary image files when the DBIO version of IMIO is +released. At that time, all disk resident images will have to be processed +to FITS format and thence into the new DBIO image format. We will keep the +old binary for the FITS writer task around for an indefinite period after +the changeover to make this possible. + +.NH +Modifications to the Current Interface +.NH 2 +Boundary extension +.PP +Automatic boundary extension is useful in applications such as filtering via +convolution, since the convolution kernel will extend beyond the boundary of +the image when near the boundary, and in applications which operate upon +subrasters, for the same reason. When reading from an image with boundary +extension in effect, IMIO will generate artificial values for the out of +bounds pixels using one of the techniques listed below. When writing to an +image with boundary extension in effect, the out of bounds pixels are +discarded. +.PP +By default, an out of bounds pixel reference will result in an error message +from IMIO. Consider an image line of length 5 pixels. The statement +.DS +\fL + buf = imgs1r (im, -1, 7) +\fR +.DE +references out of bounds by 2 pixels on either end of the image line, +referencing a total of 5+2+2=9 pixels. If boundary extension is enabled +and the get section completes successfully then \fIMemr[buf]\fR will reference +the pixel at X = -1, and \fIMemr[buf+2]\fR will reference the first inbounds +pixel. +.PP +When an image is first opened zero pixels of boundary extension are +selected, and any out of bounds references will result in an error. +To enable boundary extension \fIimseti\fR must be called on the open +image to specify the number of pixels of boundary extension permitted +before an out of bounds error occurs. +.DS +\fL + include <imset.h> + call imseti (im, IM_NBNDRYPIX, 2) +.DE +\fR +.LP +If boundary extension is enabled the type of boundary extension desired +should also be set. The possibilities are defined in \fI<imset.h>\fR and +are summarized below. +.DS +\fL + BT_CONSTANT return constant if out of bounds + BT_NEAREST return nearest boundary pixel + BT_REFLECT reflect back into image + BT_WRAP wrap around to other side + BT_PROJECT project about boundary +.ce +\fR +\fBTypes of Boundary Extension\fR +.DE +.LP +The type of boundary extension is set with the imset parameter IM_TYBNDRY. +If the BT_CONSTANT option is selected the constant value should be set with +an \fIimseti\fR or \fIimsetr\fR call to set the parameter IM_BNDRYPIXVAL. +Boundary extension works for images of any dimension up to 7 (the current +IMIO limit). A single IM_NBNDRYPIX value is used for all dimensions. +This value is used only for bounds checking, hence the value should be set +to the maximum out of bounds reference expected for any dimension. +Larger values do not "cost more" than small ones. An actual out of bounds +reference is however more expensive than an inbounds reference. +.NH 2 +Image Database Interface +.PP +The image database interface is the IMIO interface to the database +containing the image headers. In this implementation the image header is +a variable length binary structure. The first, fixed format, part of the +image header contains the standard fields in binary and is fixed in size. +This is followed by the so called "user area", a string buffer containing +a sequence of variable length, newline delimited FITS format keyword=value +header cards. When an image is opened a large user area is allocated to permit +the addition of new parameters without filling up the buffer. When the +header is subsequently updated on disk only as much disk space is used as +is needed to store the actual header. +.PP +The new header format is upwards compatible with the old image header format, +hence old images and programs do not have to be modified to use the latest +release of IMIO. In the future image headers will be maintained under DBIO, +but the routines in the image header database interface described in this +section are not exected to change. +The actual disk format of images will of course change when we switch +over to the DBIO headers. While the physical storage format of header will +change completely under DBIO, the logical schema will change very little, +i.e., our mental picture of an image header will be much as it is now. +The main difference will be the consolidation of many images into a few files, +and real support in the image header for bad pixels, history, and coordinate +transformations. In addition a number of restrictions on the "user fields" +will be lifted, the remaining distinctions between the standard and user +fields will disappear, and database operations will be much more efficient +than they are now. +.NH 3 +Library Procedures +.PP +The IMIO library procedures comprising the current image database interface +are summarized in the table below. +.DS +\fL + value = imget[bcsilrd_] (im, field) + imgstr (im, field, outstr, maxch) + imput[bcsilrd_] (im, field, value) + impstr (im, field, value) + imadd[bcsilrd_] (im, field, def_value) + imastr (im, field, def_value) + imaddf (im, field, datatype) + imdelf (im, field) + y/n = imaccf (im, field) + + list = imofnl[su] (im, template) + nchars/EOF = imgnfn (list, fieldname, maxch) + imcfnl (list) + +where + pointer im, list + char[] field, outstr, datatype, template, fieldname +\fR +.ce +\fBImage Database Interface Procedures\fR +.DE +.PP +New parameters will typically be added to the image header with either +one of the typed \fIimadd\fR procedures or with the lower level \fIimaddf\fR +procedure. +The former procedures permit the parameter to be created and the value +initialized all in one call, while the latter only creates the parameter. +In addition, the typed \fIimadd\fR procedures may be used to update the values +of existing parameters, i.e., it is not considered an error if the parameter +already exists. The principal limitation of the typed procedures is that +they may only be used to add or set parameters of a standard datatype. +The \fIimaddf\fR procedure will permit creation of parameters with more +descriptive datatypes (abstract datatypes or domains) when the interface is +recut upon DBIO. There is no support in the current interface for domains. +.PP +The value of any parameter may be fetched with one of the \fIimget\fR functions. +\fIBe careful not to confuse \fBimgets\fI with \fBimgstr\fI +(or \fBimputs\fI with \fBimpstr\fI) when +fetching or storing the string value of a field\fR. Full automatic type +conversion is provided. Any field may be read or written as a string, +and the usual type conversions are permitted for the numeric datatypes. +.PP +The \fIimaccf\fR function may be used (like the FIO \fIaccess\fR procedure) +to determine whether a field exists. Fields are deleted with \fIimdelf\fR; +it is an error to attempt to delete a nonexistent field. +.PP +The field name list procedures \fIimofnl[su]\fR, \fIimgnfn\fR, +and \fIimcfnl\fR procedures are similar to the familiar file template +facilities, except that the @file notation is not supported. The template +is expanded upon an image header rather than a directory. Unsorted lists +are the most useful for image header fields. If sorting is enabled each +comma delimited pattern in the template is sorted separately, rather than +globally sorting the entire template after expansion. Minimum match is +permitted when expanding the template, another difference from file +templates. Only actual, full length field names are placed in the output +list. +.NH 3 +Standard Fields +.PP +The database interface may be used to access any field of the image header, +including the following standard fields. Note that the nomenclature has +been changed slightly to make it more consistent with FITS. Additional +standard fields will be defined in the future. These names and their +usage may change in the next release of IMIO. +.DS +\fI + keyword type description +\fL + i_ctime l time of image creation + i_history s history string buffer + i_limtime l time when limits (minmax) were last updated + i_maxpixval r maximum pixel value + i_minpixval r minimum pixel value + i_mtime l time of last modify + i_naxis i number of axes (dimensionality) + i_naxis[1-7] l length of an axis ("i_naxis1", etc.) + i_pixfile s pixel storage file + i_pixtype i pixel datatype (SPP integer code) + i_title s title string +\fR +.ce +\fBStandard Header Fields\fR +.DE +.PP +The names of the standard fields share an "i_" prefix to reduce the possibility +of collisions with user field names, to identify the standard fields in +sorted listings, to allow use of pattern matching to discriminate between the +standard fields and user fields, and so on. For the convenience of the user, +the "i_" prefix may be omitted provided the resultant name does not match the +name of a user parameter. It is however recommended that the full name be +used in all applications software. +.NH 3 +Restrictions +.PP +The use of FITS format as the internal format for storing fields in this +version of the interface places restrictions on the size of field names and +of the string value of string valued parameters. Field names are currently +limited to eight characters or less and case is ignored (since FITS requires +upper case). The eight character limit does not apply to the standard fields. +String values are limited to at most 68 characters. If put string is passed +a longer string it will be silently truncated. Trailing whitespace and +newlines are chopped when a string value is read. + +.NH +Database Utility Tasks +.PP +Two image database utility tasks have been implemented, \fIhedit\fR and +\fIhselect\fR. \fIHedit\fR is the so called header editor, used to modify, +add, or delete selected fields of selected images. The \fIhselect\fR task +is used to select images that satisfy a selection criteria given as a boolean +expression, printing a subset of the fields of these images on the standard +output in list form. Manual pages are attached. +.PP +Both of these tasks gain most of their power from use of the \fIevexpr\fR +utility procedure, now available in FMTIO. The \fIevexpr\fR procedure takes +as input an algebraic expression (character string), parses and evaluates +the expression, and returns as output the value of the expression. +.DS +\fL + include <evexpr.h> + pointer evexpr() + + o = evexpr (expr, getop, ufcn) + +where + o Is a pointer to an operand structure + expr Is a character string + getop Is either NULL or the \fIlocpr\fL address + of a user supplied procedure called during + expression evaluation to get the value of + an external operand. + ufcn Is either NULL or the \fIlocpr\fL address + of a user supplied procedure called during + expression evaluation to satisfy a call to + an external function. +\fR +.DE +The operand structure is defined in \fB<evexpr.h>\fR. The best documentation +currently available for the operators and functions provided by \fIevexpr\fR +will be found in the manual page(s) for \fIhedit\fR. Additional documentation +will be found with the sources. The expression evaluation procedure is +probably the single largest procedure in the system (in terms of kilobytes +added to an executable) and should not be used unless it is needed, but it can +greatly increase the power of a task in the right application. +.CT +IRAF +Larry Goad +George Jacoby +Richard Wolff +Steve Ridgway (fyi) +Jeanette Barnes (fyi) +Ed Anderson (fyi) diff --git a/sys/imio/doc/imio.doc b/sys/imio/doc/imio.doc new file mode 100644 index 00000000..daa72a52 --- /dev/null +++ b/sys/imio/doc/imio.doc @@ -0,0 +1,232 @@ + IRAF IMIO OVERVIEW + 7 May 1986 + + + +1. DATA MANAGEMENT ROUTINES + +include <imhdr.h> + + im = immap (image, mode, oim) + imunmap (im) + + imdelete (image) + imrename (oldname, newname) + +where + struct imhdr *im, *oim; image header/descriptor + char image[]; image name or image section + int mode; ro, wo, rw, new_image, new_copy + +important header parameters: + + im->im_naxis number of axes + im->im_axlen[i] axis lengths + im->im_pixtype pixel datatype + im->im_datamin min pixel value + im->im_datamax max pixel value + im->im_title title string + + +Existing images are normally opened either read only or read write. +New images are opened either new_image or new_copy. In the latter case, +the third argument is a pointer to the image descriptor of an existing +image, with the new image inheriting the non-data attributes of the +existing image header. This latter feature is important for data +independence. + +The IMIO interface supports images of up to naxis=7. In a sense, all images +are multidimensional, with the higher, unused axis lengths set to 1. +An N dimensional image may therefore be accessed by a program coded to +operate upon an M dimensional image. + +The image section facility greatly inceases the flexibility of the IMIO +interface. Image sections are specified as part of the image name input +to IMOPEN, and are not visible to the applications program, which sees +a somewhat smaller image, or an image of lesser dimensionality. Some examples +are shown below. + + + section refers to + + pix[] whole image + pix[i,j] the pixel value (scalar) at [i,j] + pix[*,*] whole image, two dimensions + pix[*,-*] flip y-axis + pix[*,*,b] band B of three dimensional image + pix[*,*:s] subsample in y by S + pix[*,l] line L of image + pix[c,*] column C of image + pix[i1:i2,j1:j2] subraster of image + pix[i1:i2:sx,j1:j2:sy] subraster with subsampling + + +Sections are implemented by defining a linear transformation upon the +pixel coordinates input when image i/o takes place. All image data +transfers can be represented as subrasters defined by corner points +pointed to by the vectors VS and VE, each of length NAXIS. If an image +section is specified, the IMIO i/o routines merely transform these +vectors into PVS and PVE, the physical coordinates of the referenced +subraster, before doing any i/o. + + +2. IMIO OPTIONS + + IMIO options may be set and queried with the IMSET and IMSTAT procedures, +shown below. + + imseti (im, option, int_value) + imsetr (im, option, real_value) + + int = imstati (im, option) + real = imstatr (im, option) + +The options currently supported are shown below (from <imset.h>). + + +# IMSET.H -- Definitions for IMIO user settable options + +define IM_ADVICE 1 # RANDOM or SEQUENTIAL +define IM_NBUFS 2 # number of input buffers +define IM_COMPRESS 3 # align lines on device blocks? +define IM_NBNDRYPIX 4 # width of boundary region +define IM_TYBNDRY 5 # type of boundary extension +define IM_FLAGBADPIX 6 # set bad pix to INDEF +define IM_PIXFD 7 # pixfile fd (special devices) +define IM_WHEADER 8 # update image header at unmap time +define IM_BNDRYPIXVAL 9 # for option IM_CONSTANT + + +# Types of Boundary Extension + +define BT_CONSTANT 1 # return constant if out of bounds +define BT_NEAREST 2 # return nearest boundary pixel +define BT_REFLECT 3 # reflect back into image +define BT_WRAP 4 # wrap around to other side +define BT_PROJECT 5 # project about boundary + + +The most useful options are the multiple input buffers and boundary extension, +used to implement filtering operators. + + +3. IMIO I/O ROUTINES + + There are two basic approaches used in image interfaces: images may be +mapped into virtual memory, or accessed via conventional file i/o. IMIO +provides both but emphasizes the latter, since it is more portable, more +efficient for sequential image operations, and because it provides data +independence. All buffering is handled internally by the interface to +simplify the interface (externally), and to provide the control necessary +for sophisticated features and optimizations. + +IMIO currently provides three classes of i/o routines: [1] get/put line +random, [2] get/put line sequential, and [3] get/put subraster random. + + +3.1 Get/Put Line Random (for images of known dimension) + + ptr = im[gp]l[123][usilrdx] (im, line [, band [, ...]]) +e.g., + (short *) = imgl1s (im) # get line from 1d short image + (short *) = imgl2s (im, lineno) # get line from 2d short image + (real *) = imgl2r (im, lineno) # get line from 2d real image + (short *) = impl2s (im, lineno) # put line to 2d short image + (real *) = imgl3r (im, line, band) # get from 3d image + + +3.2 Get/Put Line Sequential (for images of any dimension) + + int = im[gp]nl[usilrdx] (im, ptr, v) +e.g., + (EOF?) = imgnlr (im, ptr, v) # get next line, real + (EOF?) = impnls (im, ptr, v) # put next line, short + +Here, STAT is either EOF or not EOF, with EOF being returned when the last +line of the image has been read. The output argument PTR is set to point +to the buffer containing the input pixels, or the buffer into which the +output pixels are to be written. The vector V, of length IM_MAXDIM, points +to the next line of the image to be read. It is set initially to [1,1,1,...] +by the user (assuming the entire image is to be accessed), and is automatically +updated by IMIO in each call. + + +3.3 Get/Put Subraster Random + + ptr = im[gp]s[123][usilrdx] +e.g., + (short *) = imgs2s (im, x1,x2, y1,y2) # get 2d subraster, short + (real *) = imps1r (im, x1,x2) # put 1d subraster, real + +These routines (and indeed all the i/o routines) can be used for either +sequential or random accesses. The subraster routines must be used to +reference outside the boundary in X. + + +3.4 Other I/O Routines + + Other, lower level routines are provided for unusual applications for which +the above routines are not suited. + + ptr = im[pg]gs[usilrdx] (im, vs, ve, ndim) + +The above puts/gets a general section of any dimension. The vectors VS and VE +define the starting and ending corners of the subraster to be accessed. +An IMFLUSH routine is provided for flushing the output buffer (remember the +delayed write). + + +In all cases, no buffers are allocated until i/o takes place, allowing IMSET +calls to set options after the image has been opened. In the case of a new +image (or new copy image), the pixel file is not allocated until i/o takes +place, giving the user time to set the number of axes, size of each axis, +pixel type, etc. after the image has been opened. + + +4. STORAGE FORMATS + + IMIO stores images on disk in line storage mode, like a multidimensional +Fortran array. Image lines are normally padded out to an integral number +of disk blocks to increase i/o efficiency. We store the header information +separately from the pixels, since the header is variable length. The pixel +storage file is preallocated and fixed in size. We call this a "static file". +A special FIO driver is provided for static files to provide optimal i/o. +Since the file is not dynamically extended at run time and the physical +blocks allocated for the file do not move about, it is possible to bypass +the host files system to directly access the data with a low level interface. + + +5. EXAMPLE (SPP) + + +# IMCOPY -- Copy an image. The header information is preserved. The output +# image has the same size, dimensionality, and pixel type as the input image. +# An image section may however be used to copy a subsection of the input image. + +procedure imcopy (in_image, out_image) + +char in_image[ARB] +char out_image[ARB] + +int npix +long v1[IM_MAXDIM], v2[IM_MAXDIM] +pointer in, out, l1, l2 +pointer immap(), imgnlr(), impnlr() + +begin + # Open/create the images. + in = immap (in_image, READ_ONLY, 0) + out = immap (out_image, NEW_COPY, im_a) + + # Initialize position vectors to line 1, column 1, band 1, ... + call amovkl (long(1), v1, IM_MAXDIM) + call amovkl (long(1), v2, IM_MAXDIM) + npix = IM_LEN(in,1) + + # Copy the image. + while (imgnlr (in, l1, v1) != EOF && impnlr (out, l2, v2) != EOF) + call amovr (Memr[l1], Memr[l2], npix) + + call imunmap (in) + call imunmap (out) +end diff --git a/sys/imio/doc/imio.hlp b/sys/imio/doc/imio.hlp new file mode 100644 index 00000000..8eb96159 --- /dev/null +++ b/sys/imio/doc/imio.hlp @@ -0,0 +1,1185 @@ +.help imio May83 "Image I/O Routines" +.sh +The Image Header + + The major difference between the prototype IMIO interface, and the final +interface, concerns the way in which the image header is implemented and +accessed. In the prototype version, we will simply read the entire header +into core and access it as an ordinary (dynamically allocated) structure. + + +.nf + ptr = immap (fname, mode, hdrsize/hdrptr) + imunmap (hdrptr) +.fi + + +The final resolution of how image headers are implemented depends on how +we decide to implement virtual structures in the spp language. The immap +calls, and the techniques used to access the fields of the image header, +can be expected to change. + +.sh +Pixel I/O + + The calling sequences for the i/o routines, described below, hopefully will +not have to be changed. We will eventually add GETPIX and PUTPIX statements +to the subset preprocessor language, to automatically generate the appropriate +low level calls. + +A generic, polymorphic GETPIX or PUTPIX statement is translated into a +reference to a low level Fortran function. The transformation is governed +by the following subprogram name generating function: + + +.rj (108 total) +GETPIX, PUTPIX --> im[gp][pls][123][silrdx] + + +.ks +.nf +For example (get, type real): + + ptr = imgp1r (hdrptr, x, npix) # get pixels + ptr = imgp2r (hdrptr, x, y, npix) + ptr = imgp3r (hdrptr, x, y, z, npix) + + ptr = imgl1r (hdrptr) # get line + ptr = imgl2r (hdrptr, y) + ptr = imgl3r (hdrptr, y, z) + + ptr = imgs1r (hdrptr, x1, x2) # get section + ptr = imgs2r (hdrptr, x1, x2, y1, y2) + ptr = imgs3r (hdrptr, x1, x2, y1, y2, z1, z2) +.fi +.ke + + +The IM?P?? procedures access a list of pixels, the coordinates of which +are given by the X, Y, Z, etc. arrays given as arguments. Note that random +access of individual pixels is provided as a special case (npix=1). + +The IM?L?? routines access the lines of an image, and the IM?S?? routines +operate on general, but connected, subsections of images. + + +.sh +Restrictions Imposed by the Initial Prototype: + + IMMAP, IMMAPNC, IMUNMAP will be implemented for image headers that are +simple binary structures (not self describing), subject to the restriction +that a file may contain only a single header. An arbitrary selection of user +defined fields will follow the standard header. The entire header will +be read into core and accessed as a simple incore structure. + +The pixels, and other variable size image substructures, will be stored +in separate files, as in the general plan. All of the standard data types +will be implemented in the disk space. The initial implementation will +support only type REAL pixels in program space. + +The following i/o routines will be implemented in the first release of +the prototype: + +.rj (12 total) + im[gp][sc][123][r] + +In words, we will be able to read and write lines and sections, with the +applications program manipulating type REAL pixels internally. The full +range of data types will be permitted in the image file as stored on disk. +Up to three dimensional images are permitted. + +.sh +IMSET Options + + The prototype need not provide multiple buffering and boundary extension +initially. + +.sh +Implementation + + Little effort should be made to make the prototype optimal. All +buffering will be locally allocated, and data will be copied to and from +the FIO buffers (the FIO buffers will not be directly accessed). Special +cases will not be optimized. The most general entry points are IMGGSR +and IMPGSR (get/put general section). Initially, all of the other entry +points can be defined in terms of these. + + +.ks +.nf +Structure of the input procedures (type REAL): + + imgl1r + imgl2r + imgl3r + imgs1r + imgs2r + imgs3r + imggsr + imggsc + imgibf + imopsf + calloc + imcssz + realloc + malloc + mfree + imsslv + imrdpx + imsoob + imnote + seek + read + imflip + imupkr + + (datatype dependent) | (datatype independent) +.fi +.ke + + + +The output procedures are structured somewhat differently, because the +transfer of a section occurs sometime after a "put section" returns, +rather than immediately as in the input procedures. Since the output +is buffered for a delayed write, we must have an IMFLUSH entry point, and +IMUNMAP must flush the output buffer before unmapping an image. + + +.ks +.nf +Structure of the output procedures (type REAL): + + impl1r + impl2r + impl3r + imps1r imunmap + imps2r | + imps3r | + impgsr | + imflush + imflsr + imflsh + imflip + imwrpx + imsoob + imnote + imwrite + fstatus + seek + write + impakr + + imgobf + imopsf + calloc + imcssz + realloc + malloc + mfree + + (datatype dependent) | (datatype independent) +.fi +.ke + + +.sh +Semicode for the Basic I/O Routines + + The IMGGS? and IMPGS? procedures get and put general N-dimensional +image sections of a specific datatype. There is no intrinsic limit on +the maximum number of dimensions, and the full range (8) of disk datatypes +are easily supported. The subscript for a particular dimension may run +either forward or backward. The semicode is written generically, allowing +code to be machine generated for all program space datatypes (6). + +We do not address the problems of boundary extension and multiple buffering +here, but these features can be easily added in the future. This version +of IMIO assumes that pixels are stored on disk in line storage mode, with +no interlacing of bands. + + +IMGGS? gets a general section, and converts it to the datatype indicated +by the type suffix. + + +.ks +.nf +pointer procedure imggs$t (imdes, vs, ve) + +imdes pointer to image descriptor structure +vs,ve coordinates of starting and ending points + +begin + bp = imggsc (imdes, vs, ve, TY_PIXEL, totpix) + if (imdes.pixtype != TY_PIXEL) + call imupk$t (*bp, *bp, totpix, imdes.pixtype) + return (coerce (bp, TY_CHAR, TY_PIXEL)) +end +.fi +.ke + + + +IMGGSC gets a general section from an imagefile into a buffer. Upon +exit, the buffer contains the requested section, with the pixels still +in the same datatype they were in the imagefile. The buffer is made +large enough to accommodate the pixels in either datatype. + + +.ks +.nf +pointer procedure imggsc (imdes, vs, ve, dtype, totpix) + +imdes pointer to image descriptor structure +vs,ve coordinates of starting and ending points +dtype datatype of pixels required by calling program +bp pointer to CHAR buffer to hold pixels + +begin + # Get an (input) buffer to put the pixels into. Prepare the + # section descriptor vectors V, VINC. + + bp = imgibf (imdes, vs, ve, dtype) + call imsslv (imdes, vs, ve, v, vinc, npix) + + # Extract the pixels. IMRPIX reads a contiguous array of + # pixels into the buffer at the specified offset, incrementing + # the offset when done. The pixels are type converted if + # necessary. + + offset = 0 + + repeat { + call imrdpx (imdes, *(bp+offset), v, npix) + if (vinc[1] < 0) + call imflip (*(bp+offset), npix, sizeof(imdes.pixtype)) + offset = offset + npix + + for (d=2; d <= imdes.ndim; d=d+1) { + v[d] += vinc[d] + if ((v[d] - ve[d] == vinc[d]) && d < imdes.ndim) + v[d] = vs[d] + else { + d = 0 + break + } + } + } until (d >= imdes.ndim) + + totpix = offset + return (bp) +end +.fi +.ke + + + + + +Prepare the section descriptor vectors V and VINC. V is a vector specifying +the coordinates at which the next i/o transfer will take place. VINC is +a vector specifying the loop step size. + + +.ks +.nf +procedure imsslv (imdes, vs, ve, v, vinc, npix) + +begin + # Determine the direction in which each dimension is to be + # traversed. + + do i = 1, imdes.ndim + if (vs[i] <= ve[i]) + vinc[i] = 1 + else + vinc[i] = -1 + + # Initialize the extraction vector (passed to IMRDS? to read a + # contiguous array of pixels). Compute length of a line. + + do i = 1, imdes.ndim + v[i] = vs[i] + + if (vs[1] > ve[1]) { + v[1] = ve[1] + npix = vs[1] - ve[1] + 1 + } else + npix = ve[1] - vs[1] + 1 +end +.fi +.ke + + + + + +The put-section procedure must write the contents of the output buffer +to the image, using the section parameters saved during the previous call. +The new section parameters are then saved, and the buffer pointer is +returned to the calling program. The calling program subsequently fills +the buffer, and the sequence repeats. + + +.ks +.nf +pointer procedure impgs$t (imdes, vs, ve) + +imdes pointer to image descriptor structure +vs,ve coordinates of starting and ending points + +begin + # Flush the output buffer, if appropriate. IMFLUSH calls + # one of the IMFLS? routines, which write out the section. + + call imflush (imhdr) + + # Get an (output) buffer to put the pixels into. Save the + # section parameters in the image descriptor. Save the epa + # of the typed flush procedure in the image descriptor. + + bp = imgobf (imdes, vs, ve, TY_PIXEL) + imdes.flush_epa = loc (imfls$t) + + return (bp) +end +.fi +.ke + + + +Flush the output buffer, if a put procedure has been called, and the +buffer has not yet been flushed. The output buffer is flushed automatically +whenever a put procedure is called, when an image is unmapped, or when +the applications program calls IMFLUSH. + + +.ks +.nf +procedure imfls$t (imdes) + +begin + # Ignore the flush request if the output buffer has already been + # flushed. + + if (imdes.flush == YES) { + bdes = imdes.obdes + bp = bdes.bufptr + + # Convert datatype of pixels, if necessary, and flush buffer. + if (imdes.pixtype != TY_PIXEL) + call impak$t (*bp, *bp, bdes.npix, imdes.pixtype) + call imflsh (imdes) + + imdes.flush = NO + } +end +.fi +.ke + + +.ks +.nf +procedure imflsh (imdes) + +begin + # Determine the direction in which each dimension is to be + # traversed. + + bdes = imdes.obdes + call imsslv (imdes, bdes.vs, bdes.ve, v, vinc, npix) + + # Write out the pixels. IMWRPX writes a contiguous array of + # pixels at the specified offset. + + offset = 0 + + repeat { + if (vinc[1] < 0) + call imflip (*(bp+offset), npix, sizeof(imdes.pixtype)) + call imwrpx (imdes, *(bp+offset), v, npix) + offset = offset + npix + + for (d=2; d <= imdes.ndim; d=d+1) { + v[d] += vinc[d] + if ((v[d] - ve[d] == vinc[d]) && d < imdes.ndim) + v[d] = vs[d] + else { + d = 0 + break + } + } + } until (d >= imdes.ndim) +end +.fi +.ke + + + + +Read a contiguous array of NPIX pixels, starting at the point defined by +the vector V, into the callers buffer. + + +.ks +.nf +procedure imrdpx (imdes, buf, v, npix) + +begin + # Check that the access does not reference out of bounds. + + if (imsoob (imdes, v, npix)) + call imerr (imname, subscript_out_of_range) + + # Seek to the point V in the pixel storage file. Compute size + # of transfer. + + call seek (imdes.pfd, imnote (imdes, v)) + nchars = npix * sizeof (imdes.pixtype) + + # Read in the data. + if (read (imdes.pfd, buf, nchars, junk) != nchars) + call imerr (imname, missing_pixels) +end +.fi +.ke + + + +Write a contiguous array of NPIX pixels, starting at the point defined by +the vector V, into the pixel storage file. + + +.ks +.nf +procedure imwrpx (imdes, buf, v, npix) + +begin + # Check that the access does not reference out of bounds. + + if (imsoob (imdes, v, npix)) + call imerr (imname, subscript_out_of_range) + + # Seek to the point V in the pixel storage file. Note that + # when writing to a new image, the next transfer may occur + # at a point beyond the current end of file. If so, write + # out zeros until the desired offset (which is in bounds) + # is reached. + + file_offset = imnote (imdes, v) + if (file_offset > imdes.file_size) + [write zeros until the desired offset is reached] + else + call seek (imdes.pfd, file_offset) + + # Compute size of transfer. If transferring an entire line, + # increase size of transfer to the physical line length, + # to avoid having to enblock the data. NOTE: buffer must + # be large enough to guarantee no memory violation. + + if (v[1] == 1 && npix == imdes.len[1]) + nchars = imdes.physlen[1] * sizeof (imdes.pixtype) + else + nchars = npix * sizeof (imdes.pixtype) + + call write (imdes.pfd, buf, nchars) + imdes.file_size = max (imdes.file_size, file_offset+nchars) +end +.fi +.ke + + + + +IMNOTE computes the physical offset of a particular pixel in the +pixel storage file. If the disk datatype is UBYTE, this is the offset +of the char containing the subscripted byte. + + +.ks +.nf +long procedure imnote (imdes, v) + +begin + pixel_offset = v[1] + for (i=2; i <= imdes.ndim; i=i+1) + pixel_offset += (v[i]-1) * imdes.physlen[i] + + char_offset0 = (pixel_offset-1) * sizeof (imdes.pixtype) + return (imdes.pixoff + char_offset0) +end +.fi +.ke + + + +Convert a vector of any datatype to type PIXEL ($t). The input and +output vectors may be the same, without loss of data. The input and +output datatypes may be the same, in which case no conversion is +performed. + + +.ks +.nf +procedure imupk$t (a, b, npix, dtype) + +begin + switch (dtype) { + case TY_USHORT: + call achtu$t (a, b, npix) + case TY_SHORT: + call achts$t (a, b, npix) + case TY_INT: + call achti$t (a, b, npix) + case TY_LONG: + call achtl$t (a, b, npix) + case TY_REAL: + call achtr$t (a, b, npix) + case TY_DOUBLE: + call achtd$t (a, b, npix) + case TY_COMPLEX: + call achtx$t (a, b, npix) + default: + call syserr (unknown_datatype_in_imagefile) + } +end +.fi +.ke + + + +Convert a vector of type PIXEL ($t) to any datatype. The input and +output vectors may be the same, without loss of data. The input and +output datatypes may be the same, in which case no conversion is +performed. + + +.ks +.nf +procedure impak$t (a, b, npix, dtype) + +begin + switch (dtype) { + case TY_USHORT: + call acht$tu (a, b, npix) + case TY_SHORT: + call acht$ts (a, b, npix) + case TY_INT: + call acht$ti (a, b, npix) + case TY_LONG: + call acht$tl (a, b, npix) + case TY_REAL: + call acht$tr (a, b, npix) + case TY_DOUBLE: + call acht$td (a, b, npix) + case TY_COMPLEX: + call acht$tx (a, b, npix) + default: + call syserr (unknown_datatype_in_imagefile) + } +end +.fi +.ke + + +.sh +Data Structure Management + + When an image is mapped, buffer space is allocated for a copy of +the image header, and for the image descriptor (used by IMIO while an +image is mapped). When the first i/o transfer is done on an image, +either an input or an output data buffer will be created. The size of +this buffer is governed by the size of the transfer, and by the datatypes +of the pixels on disk and in program space. + +If a new image is being written, the pixel storage file is created at +the time of the first PUTPIX operation. The physical characteristics +of the new image, defined by the image header of the new image, are +unalterable once the first i/o operation has occurred. Accordingly, +the number of dimensions, length of the dimensions, datatype of the +pixels on disk, and so on must be set (in the image header structure) +before writing to the new image. + +The only exception to this rule may be the addition of new lines to a +two dimensional image stored in line storage mode, or the addition of +new bands to a multiband image stored in band sequential (noninterlaced) +mode. It is not always possible to modify the dimensions or size of +an existing image. + +It is possible to preallocate space for an image (using FALOC). This +may result in a more nearly contiguous file, and may make writing a +new image slightly more efficient, since it will not be necessary +to write blocks of zeros in IMPGS?. Preallocation will occur +automatically in systems where it is desirable. + +.sh +Pixel Buffer Management + + There may be any number of input buffers per image, but only a single +output buffer. By default there is only a single input buffer. The input +and output buffers are distinct: the same buffer is never used for both +input and output (unlike FIO). + +The size of a buffer may range from one pixel, to the entire image (or +larger if boundary extension is in use). If multiple buffers are in use, +all buffers do not have to be the same size. The size of a buffer may +vary from one GETPIX or PUTPIX call to the next. + +If multiple input buffers are in use, buffers are allocated in a strictly +round robin fashion, one per GETPIX call. Several buffers may contain +data from the same part of the image. Once the desired number of buffers +have been filled, a buffer "goes away" with each subsequent GETPIX call. + + +IMGIBF gets an input buffer. When called to get a line or section, +the vectors VS and VE specify the subsection to be extracted. +This information is saved in the buffer descriptor, along with the +datatype of the pixels and the dimension of the section. + +When IMGIBF is called to get a list of pixels, VS and VE would have to be +replaced by a set of NPIX such vectors, to fully specify the section. +It is impractical to save this much information in the buffer descriptor, +so when creating a buffer to contain a list of pixels, VS and VE are faked +to indicate a one dimensional section of the appropriate size. + + + + +.ks +.nf +pointer procedure imgibf (imdes, vs, ve, dtype) + +imdes image descriptor +vs,ve define the number of pixels to be buffered +dtype the datatype of the pixels in the program + +begin + # If first input transfer, allocate and initialize array of + # input buffer descriptors. + + if (imdes.ibdes == NULL) { + call imopsf (imdes) + call calloc (imdes.ibdes, LEN_BDES * imdes.nbufs, TY_STRUCT) + } + + # Compute pointer to the next input buffer descriptor. + # Increment NGET, the count of the number of GETPIX calls. + + bdes = &imdes.ibdes [mod (imdes.nget, imdes.nbuf) + 1] + imdes.nget += 1 + + # Compute the size of the buffer needed. Check buffer + # descriptor to see if the old buffer is the right size. + # If so, use it, otherwise make a new one. + + nchars = imcssz (imdes, vs, ve, dtype) + + if (nchars < bdes.bufsize) + call realloc (bdes.bufptr, nchars, TY_CHAR) + else if (nchars > bdes.bufsize) { + call mfree (bdes.bufptr, TY_CHAR) + call malloc (bdes.bufptr, nchars, TY_CHAR) + } + + # Save section coordinates, datatype in buffer descriptor, and + # return buffer pointer to calling program. + + bdes.bufsize = nchars + bdes.dtype = dtype + bdes.npix = totpix + + do i = 1, imdes.ndim { + bdes.vs[i] = vs[i] + bdes.ve[i] = ve[i] + } + + return (coerce (bdes.bufptr, TY_CHAR, dtype) +end +.fi +.ke + + + + +.ks +.nf +pointer procedure imgobf (imdes, vs, ve, dtype) + +imdes image descriptor +vs,ve define the number of pixels to be buffered +dtype the datatype of the pixels in the program + +begin + # If first write, and if new image, create pixel storage file, + # otherwise open pixel storage file. Allocate and initialize + # output buffer descriptor. + + if (imdes.obdes == NULL) { + call imopsf (imdes) + call calloc (imdes.obdes, LEN_BDES, TY_STRUCT) + } + + bdes = imdes.obdes + + # Compute the size of buffer needed. Add a few extra chars + # to guarantee that there won't be a memory violation when + # writing a full physical length line. + + nchars = imcssz (imdes, vs, ve, dtype) + + (imdes.physlen[1] - imdes.len[1]) * sizeof (imdes.pixtype) + + if (nchars < bdes.bufsize) + call realloc (bdes.bufptr, nchars, TY_CHAR) + else if (nchars > bdes.bufsize) { + call mfree (bdes.bufptr, TY_CHAR) + call malloc (bdes.bufptr, nchars, TY_CHAR) + } + + # Save section coordinates, datatype of pixels in buffer + # descriptor, and return buffer pointer to calling program. + + bdes.bufsize = nchars + bdes.dtype = dtype + bdes.npix = totpix + + do i = 1, imdes.ndim { + bdes.vs[i] = vs[i] + bdes.ve[i] = ve[i] + } + + return (coerce (bdes.bufptr, TY_CHAR, dtype) +end +.fi +.ke + + + +Given two vectors describing the starting and ending coordinates +of an image section, compute and return the amount of storage needed +to contain the section. Sufficient storage must be allocated to +hold the largest datatype pixels which will occupy the buffer. + + + +.ks +.nf +long procedure imcssz (imdes, vs, ve, dtype) + +begin + pix_size = max (sizeof(imdes.pixtype), sizeof(dtype)) + npix = 0 + + do i = 1, imdes.ndim + if (vs[i] <= ve[i]) + npix *= ve[i] - vs[i] + 1 + else + npix *= vs[i] - ve[i] + 1 + + return (npix * pix_size) +end +.fi +.ke + + +.sh +Mapping and unmapping Image Structures + + An imagefile must be "mapped" to an image structure before the +structure can be accessed. The map operation associates a file with +a defined structure. + +The IMMAP procedure must allocate a buffer for the image header +structure, and for the image descriptor structure. If an existing +imagefile is being mapped, the header is copied into memory from +the imagefile. If a new image is being mapped, the header structure +is allocated and initialized. + +If an image is being mapped as a "new copy", a new header +structure is created which is a copy of the header of an image which +has already been mapped. The entire image header, including any +application specific fields, is copied. + +After copying an image header for a NEW_COPY image, the header field +containing the name of the pixel storage file is cleared. A "new copy" +image structure does not inherit any pixels. Any similar substructures +which describe the attributes of the pixels (i.e., the blank pixel +list, the histogram) must also be initialized. + +Note that the "image descriptor" buffer allocated below actually +contains the image descriptor, followed by the standard image header +(at offset IMHDR_OFF), followed by any user fields. If an existing +image structure is being mapped, the caller supplies the length of +the user area of the header as the third argument to IMMAP. + +IMMAP returns a pointer to the first field of the standard header +as the function value. The image descriptor is invisible to the +calling program. + + + +.ks +.nf +pointer procedure immap (fname, mode, hdr_arg) + +begin + # Add code here to handle section suffixes in imagefile + # name strings (e.g. "image[*,5]"). + + # Open image header file. + hfd = open (fname, mmap[mode], BINARY_FILE) + + # Allocate buffer for image descriptor/image header. Note + # the dual use of the HDR_ARG argument. + + if (mode == NEW_COPY) + sz_imhdr = hdr_arg.sz_imhdr + else + sz_imhdr = (LEN_IMHDR + int(hdr_arg)) * SZ_STRUCT + + call calloc (imdes, SZ_IMDES + sz_imhdr, TY_STRUCT) + imhdr = imdes + IMHDR_OFF + + [initialize the image descriptor, including the default + image section (optionally set by user with suffix above).] + + # Initialize the mode dependent fields of the image header. + switch (mode) { + case NEW_COPY: + call im_init_newcopy (imdes, hdr_arg) + case NEW_IMAGE: + [initialize the image header] + default: + call seek (hfd, BOFL) + n = read (hfd, Memi[imhdr], sz_imhdr) + if (n < SZ_IMHDR || strne (IM_MAGIC(imhdr), "imhdr")) { + call mfree (imdes) + call imerr (fname, file_not_an_imagefile) + } else if (mode == READ_ONLY) + call close (hfd) + } + + [initialize those fields of the image header which are not + dependent on the mode of access.] + + return (imhdr_pointer) +end +.fi +.ke + + + + +.ks +.nf +procedure imunmap (imhdr) + +begin + imdes = imhdr - IMHDR_OFF + + # Flush the output buffer, if necessary. + call imflush (imhdr) + + # Append the bad pixel list. + if (the bad pixel list has been modified) { + if (file_size < blist_offset) + [write out zeros until the offset of the bad pixel + list is reached] + [append the bad pixel list] + [free buffer space used by bad pixel list] + } + + call close (imdes.pfd) + + # Update the image header, if necessary (count of bad pixels, + # minimum and maximum pixel values, etc.). + + if (imdes.update == YES) { + if (no write permission on image) + call imerr (imname, cannot_update_imhdr) + call imuphdr (imdes) + call close (imdes.hfd) + } + + # Free buffer space. + for (i=1; i <= imdes.nbufs; i=i+1) + call mfree (imdes.ibdes[i].bufptr, TY_CHAR) + call mfree (imdes.obdes.bufptr, TY_CHAR) + call mfree (imdes, TY_STRUCT) +end +.fi +.ke + + +IMFLUSH indirectly references a typed flush procedure, the entry point +address of which was saved in the image descriptor at the time of the +last IMPGS? call. The problem here is that IMFLUSH must work properly +regardless of the data type of the pixels in the output buffer. To +ensure this, and to avoid having to link in the full matrix of 48 type +conversion routines, we call LOC in the put-section procedure to reference +the appropriate typed flush routine. + + + +.ks +.nf +procedure imflush (imhdr) + +begin + if (imdes.flush == YES) + call zcall1 (imdes.flush_epa, imdes) +end +.fi +.ke + + + +The following procedure is called by the IMGOBF and IMGIBF routines +to open the pixel storage file, during the first PUTPIX operation on +a file. + + +.ks +.nf +procedure imopsf (imdes) + +begin + switch (imdes.mode) { + case READ_ONLY, READ_WRITE, WRITE_ONLY, APPEND: + imdes.pfd = open (imdes.pixfile, imdes.mode, BINARY_FILE) + if (read (imdes.pfd, pix_hdr, SZ_PIXHDR) < SZ_IMMAGIC) + call imerr (imname, cannot_read_pixel_storage_file) + else if (strne (pix_hdr.im_magic, "impix")) + call imerr (imname, not_a_pixel_storage_file) + + case NEW_COPY, NEW_FILE, TEMP_FILE: + # Get the block size for device "imdir$", and initialize + # the physical dimensions of the image, and the absolute + # file offsets of the major components of the pixel storage + # file. + + dev_block_size = fdevblk ("imdir$") + [initialize im_physlen, im_pixels, im_hgmoff fields + in image header structure] + + # Open the new pixel storage file (preallocate space if + # enabled on local system). Call FADDLN to tell FIO that + # the pixfile is subordinate to the header file (for delete, + # copy, etc.). Save the physical pathname of the pixfile + # in the image header, in case "imdir$" changes. + + call mktemp ("imdir$im", temp, SZ_FNAME) + call fpathname (temp, imhdr.pixfile, SZ_PATHNAME) + + if (preallocation of imagefiles is enabled) + call falloc (imhdr.pixfile, sz_pixfile) + imdes.pfd = open (imdes.pixfile, NEW_FILE, BINARY_FILE) + call faddln (imdes.imname, imdes.pixfile) + + # Write small header into pixel storage file. Allows + # detection of headerless pixfiles, and reconstruction + # of header if it gets lost. + + [write pix_hdr header structure to pixel storage file] + + default: + call imerr (imname, illegal_access_mode) + } +end +.fi +.ke + + +.sh +Data Structures + + An imagefile consists of two separate files. The first file contains +the image header. In the prototype, there may be only a single header per +header file. The header consists of the standard image header, followed +by an arbitrary number of user defined fields. + +The standard part of the image header has a fixed structure. All the variable +size components of an image are stored in the pixel storage file. The +name of the pixel storage file, and the offsets to the various components +of the image, are stored in the image header. The name of the image header +file is in turn stored in the header area of the pixel storage file, +making it possible to detect headerless images. + +The pixel storage file contains a small header, followed by the pixels +(aligned on a block boundary), optionally followed by a fixed size +histogram, and a variable size bad pixel list. + + +.ks +.nf + Structure of an Imagefile + + --------- --------- + | <---- | + standard ----> header + image | + header PIXELS + | | + user histogram (optional) + fields | + | bad + \|/ pixel (optional) + ---------- list + | + \|/ + --------- +.fi +.ke + + +The image header file, which is small, will reside in the users own +directory. The pixel storage file is generated and manipulated +transparently to the applications program and the user, and resides +in the temporary files system, in the logical directory "imdir$". + +Storing the parts of an image in two separate files does cause problems. +The standard file operators, like DELETE, COPY, RENAME, and so on, +either cannot be used to manipulate imagefiles, or must know about +imagefiles. + +To solve this problem, without requiring FIO to know anything about IMIO +or VSIO data structures, two operators will be added to FIO. The first +will tell FIO that file 'A' has a subordinate file 'B' associated with +it. Any number of subordinate files may be associated with a file. +The information will be maintained as a list of file names in an invisible +text file in the same directory as file 'A'. + +The second operator will delete the link to a subordinate file. The FIO +procedures DELETE and RENAME will check for subordinate files, as will CL +utilities like COPY. + +.sh +The Standard Image Header + + The standard fields of an image header describe the physical +characteristics of the image (required to access the pixels), plus +a few derived or historic attributes, which are commonly associated +with images as used in scientific applications. + + +.ks +.nf +struct imhdr { + char im_magic[5] # contains the string "imhdr" + long im_hdrlen # length of image header + int im_pixtype # datatype of the pixels + int im_ndim # number of dimensions + long im_len[MAXDIM] # length of the dimensions + long im_physlen[MAXDIM] # physical length (as stored) + long im_pixels # offset of the pixels + long im_hgmoff # offset of hgm pixels + long im_blist # offset of bad pixel list + long im_szblist # size of bad pixel list + long im_nbpix # number of bad pixels + long im_cdate # date of image creation + long im_mdate # date of last modify + real im_max # max pixel value + real im_min # min pixel value + struct histogram im_hgm # histogram descriptor + struct coord_tran im_coord # coordinate transformations + char im_pixfile[SZ_PATHNAME] # name of pixel storage file + char im_name[SZ_IMNAME] # image name string + char im_history[SZ_IMHIST] # history comment string +} +.fi +.ke + + + +The histogram structure, if valid, tells where in the pixel storage file +the histogram is stored, and in addition summarizes the principal +attributes of the histogram. All of these quantities are directly +calculable, except for the last three. The modal value is determined +by centering on the (major) peak of the histogram. LCUT and HCUT define +an area, centered on the modal value, which contains a certain fraction +of the total integral. + + +.ks +.nf +struct histogram { + int hgm_valid # YES if histogram is valid + int hgm_len # number of bins in hgm + long hgm_npix # npix used to compute hgm + real hgm_min # min hgm value + real hgm_max # max hgm value + real hgm_integral # integral of hgm + real hgm_mean # mean value + real hgm_variance # variance about mean + real hgm_skewness # skewness of hgm + real hgm_mode # modal value of hgm + real hgm_lcut # low cutoff value + real hgm_hcut # high cutoff value +} +.fi +.ke + + + +The coordinate transformation descriptor is used to map pixel coordinates +to some user defined virtual coordinate system, (useful when displaying the +contents of an image). For lack of a significantly better scheme, we have +simply adopted the descriptor defined by the FITS standard. + + +.ks +.nf +struct coord_tran { + real im_bscale # pixval scale factor + real im_bzero # pixval offset + real im_crval[MAXDIM] # value at pixel + real im_crpix[MAXDIM] # index of pixel + real im_cdelt[MAXDIM] # increment along axis + real im_crota[MAXDIM] # rotation angle + char im_bunit[SZ_BUNIT] # pixval ("brightness") units + char im_ctype[SZ_IMCTYPE,MAXDIM] # coord units +} +.fi +.ke + + + +The image and buffer descriptors are used internally by IMIO while +doing i/o on a mapped image. The image descriptor structure is +allocated immediately before the image header, is transparent to the +applications program, and is used to maintain runtime data, which +does not belong in the image header. + + +.ks +.nf +struct image_descriptor { + long file_size # size of pixfile + long nget # number getpix calls + int nbufs # number of in buffers + int flush # flush outbuf? + int update # update header? + int pfd # pixfile fd + int hfd # header file fd + int flush_epa # epa of imfls? routine + struct buffer_descriptor *ibdes # input bufdes + struct buffer_descriptor *obdes # output bufdes + char imname[SZ_FNAME] # imagefile name +} +.fi +.ke + + + +.ks +.nf +struct buffer_descriptor { + char *bufptr # buffer pointer + int dtype # datatype of pixels + long npix # number of pixels in buf + long bufsize # buffer size, chars + long vs[MAXDIM] # section start vector + long ve[MAXDIM] # section end vector +} +.fi +.ke diff --git a/sys/imio/doc/imio.ms b/sys/imio/doc/imio.ms new file mode 100644 index 00000000..2302a8ff --- /dev/null +++ b/sys/imio/doc/imio.ms @@ -0,0 +1,295 @@ +.ce +\fBThe IRAF Image I/O Interface\fR +.ce +\fIDesign Strategies\fR +.ce +\fIStatus and Plans\fR +.sp +.ce +Doug Tody +.ce +November 1983 +.sp 3 +.NH +Introduction +.PP +Bulk data arrays are accessed in IRAF SPP programs via the Image I/O +(IMIO) interface. IMIO is used to create, read, and write IRAF +\fBimagefiles\fR. The term \fBimage\fR refers to data arrays of one, two, +or more dimensions. Each "imagefile" actually consists of two files: +the \fBheader file\fR and the \fBpixel storage file\fR. Seven disk datatypes +are currently supported. +.PP +The IMIO calling sequences are summarized in the \fIProgrammer's Crib +Sheet\fR. There is as yet no Reference Manual or User's Guide for the package. +Our intention in this document is merely to introduce IMIO, to summarize its +capabilities, and note what is planned for the future. +.NH +Structure +.PP +The basic structure of an applications program which uses IMIO is shown +below. In the current implementation of IMIO the image header is a simple +binary structure, but this will change when DBIO (the database interface) +is implemented. The pixel storage file is accessed via FIO (the IRAF File +I/O interface) which permits arbitrarily large buffers and double or multiple +buffered i/o. All buffers are dynamically allocated and deallocated using +the facilities provided by the MEMIO interface. + +.DS +.cs 1 22 +Command Language + (applications program) + IMIO + DBIO + FIO + OS | + MEMIO | (operating system) + OS | + + + (system independent) | (system dependent) +.DE +.cs 1 + +.NH +Summary of What is Provided by the Current Interface +.PP +The IMIO interface code is mostly concerned with pixel buffer allocation and +manipulation, and with mapping requests to read and write image sections +into file i/o calls. FIO handles all low level i/o. The efficiency of FIO +for sequential image access stems from the fact that the FIO buffers may +be made as large as desired transparently to the outside world (i.e., IMIO), +the number of FIO buffers is variable, and full read-ahead and write-behind +are implemented (provided the OS provides asynchronous i/o facilities). +.PP +IMIO currently provides the following functions/features: + +.RS +.IP (1) +7 disk datatypes (ushort, silrdx). +.IP (2) +6 in-core datatypes (the standard silrdx). +.IP (3) +Images of up to 7 dimensions are currently supported. The maximum +dimensionality is a sysgen parameter. +.IP (4) +Fully automatic multidimensional buffer allocation, resizing, +and deallocation. There is no fixed limit on the size of a buffer (a subraster +may actually exceed the size of the image if boundary extension is employed). +The size of an image is limited only by the resources of the machine. +.IP (5) +An arbitrary number of input buffers (default 1) may be used to access an +image. Buffers are allocated in a round robin fashion, and need not be the +same size, dimension, or datatype. This feature is especially useful for +convolutions, block averaging, and similar operators. +.IP (6) +Fully automatic type conversion on both input and output. Conversion occurs +only when data is accessed, so one need not type convert the entire image +to access a subraster. +.IP (7) +IMIO implements general image sections (described below), coordinate flip, +and subsampling. +.IP (8) +The dimensionality of the image expected by the applications code and the +actual dimension of an image need not agree. If an operator expects a one +dimensional image, for example, it may be used to operate on any line, column, +or pillar of a three dimensional image, on both input and output (see +discussion on image sections below). +.IP (9) +Both "compressed" and "block aligned" storage modes are supported, with IMIO +automatically selecting the optimal choice during image creation (if the +packing efficiency is not above a certain threshold then image lines are +not block aligned). The device blocksize is determined at runtime and +devices with different blocksizes may coexist. +.IP (10) +IMIO may be advised if i/o is to be either highly sequential or highly +random; the buffering strategy will be modified to increase i/o efficiency. +.IP (11) +Pixel storage files may reside on special devices if desired. For example, +the current \fBdisplay\fR routine accesses the image display device as a random +access imagefile via the standard IMIO interface. This was easy to do +because FIO is device independent and allows new devices to be interfaced +dynamically at run time (other examples of special "devices" are the CL, +magtapes, and strings). +.IP (12) +The image header file, which is small, is normally placed in the user's +own directory system. The pixel storage file, on the other hand, is often +very large and is normally placed in a different filesystem. This is +transparent to the user, and has the advantage that bulk data does not +have to be backed up on tape when the user disk is backed up, and throughput +is often higher because the pixel filesystem can be optimized for large +transfers and more nearly contiguous files. +.IP (13) +An image opened with the mode "new_copy" inherits the full image header +of an existing image, including all user defined fields, minus the pixels +and minus all fields which depend on the actual values of the pixels. +.RE + +.PP +The basic i/o facilities are described in the crib sheet. In short, we +have procedures to get or put pixels, lines, or sections. The put calls +are identical to the get calls and all buffer allocation and manipulation +is performed by IMIO. The pixel access routines access a list of pixels +(described by one, two, or more integer arrays giving the coordinates of +the pixels, which are fetched in storage order to minimize seeks). +An additional set of calls are available for accessing all of the lines +in an image sequentially in storage order, regardless of the dimensionality +of the image (as in the FITS reader). +.NH +Planned Enhancements to IMIO +.PP +The following enhancements are currently planned for IMIO; they are +arranged more or less with the highest priority items first. The DBIO +header, boundary extension facilities, and bad pixel list features are +of the highest priority and will be implemented within the next few months. + +.RS +.IP (1) +Replacement of the current rather rigid binary header by the highly +extensible yet efficient DBIO header. +.IP (2) +Automatic boundary extension by any of the following techniques: +nearest neighbor, reflection, projection, wrap around, indefinite, +constant, apodize. Useful for convolutions and subraster extraction +near the boundary of an image. +.IP (3) +Bad pixel list manipulation. A list of bad pixels will optionally be +associated with each image. The actual value of each "bad" pixel in the +image will be a reasonable, artificially generated value. Programs which +do not need to know about bad pixels, such as simple pointwise image +operators, will see only reasonable values. IMIO will provide routines to +merge (etc.) bad pixel lists in simple pointwise image operations. +Operators which need to be able to deal with bad pixels, such as surface +fitting routines, will advise IMIO to replace the bad pixels with the +value INDEF upon input. +.IP (4) +Implement the pixel access routines (\fBimgp__\fR and \fBimpp__\fR). +Currently only the line and section routines are implemented. The section +routines may be used to access individual pixels, but this involves quite +a bit of overhead and disk seeks are not optimized. +.IP (5) +Optimization to the get/put line procedures to work directly +out of the FIO buffers when possible for increased efficiency. +.IP (6) +IMIO (and FIO) dynamically allocate all buffers. Eventually we will add +an "advice" option permitting buffers to be allocated in a region +of memory which is \fIshared\fR with a bit-mapped array processor. +The VOPS primitives, already used extensively for vector operations, +will be interfaced to the AP and applications sofware will then make use +of the AP without modification and without introducing any device +dependence. Note that CSPI is currently marketing a 7 Mflop bit-mapped +AP for the VAX, and Masscomp provides a similar device for their 680000 based +supermicro. +.IP (6) +Support for the unsigned byte disk datatype. +.DE + +.PP +Long range improvements include language support for image sections in +the successor to the SPP (subset) language compiler, and extensions for +block storage mode of images on disk. Currently all images are stored on +disk in line storage mode (i.e., like a Fortran array). +.NH +Image Sections +.PP +Image sections are used to specify the region of an image to be operated +upon. The essential idea is that when the user passes the name of an +image to a task, a special notation is employed which specifies the section +of the image to be operated upon. The image section is decoded by IMIO +at "immap" time and is completely transparent to the applications code +(when a section is used, the image appears smaller to the applications +program). If no section is specified then the entire image is accessed. +.PP +For example, suppose we want to display the image "pix" in frame 1 of the +image display, using all the default parameters: + +.nf + cl> display pix, 1 +.fi + +This works fine as long as "pix" is a one or two dimensional image. If it +is a three dimensional image, we will see only the first band. To display +some other band, we must specify a two-dimensional \fIsection\fR of the +three dimensional image: + +.nf + cl> display pix[*,*,5], 1 + cl> display pix[5], 1 +.fi + +Either command above would display band 5 of the three dimensional image +(higher dimensional images are analogous). To display a dimensional image +with the columns flipped: + +.nf + cl> display pix[*,\(mi*], 1 +.fi + +This command flips the y-axis. To display a subraster: + +.nf + cl> display pix[30:40,310:300], 1 +.fi + +would display the indicated eleven pixel square subraster. To display a +2048 square image on a 512 square display by means of subsampling: + +.nf + cl> display pix[*:4,*:4], 1 +.fi +.NH +Use of Virtual Memory +.PP +The current implementation of IMIO does not make use of any virtual memory +facilities. We have had little incentive to do so because 4.1BSD Berkeley +UNIX does not have a very good implementation of virtual memory (few systems +do, it seems - DG/AOS, which is what CTIO runs, does not have a +good implemenation either). Various strategies can, however, be employed +to take advantage of virtual memory on a machine which provides good +virtual memory facilities. +.PP +One technique is to use IMIO to "extract a subraster" which is in fact +the entire image. The current implementation of IMIO would copy rather +than map the image, but \fIif\fR no type conversion were required, +if no section was specified, if the image was not block-aligned, +and if referencing out of bounds was not required, +IMIO could instead map the image directly into virtual memory. +This would be an easy enhancement to make to IMIO because all data is +accessed with pointers. The code fragment in the following example +demonstrates how this is done in the current version of IMIO. + +.DS +.cs 1 22 +int ncols, nlines +pointer header, raster +pointer immap(), imgs2r() + +begin + # Open or "map" the image. "Imagefile" is a file name + # or a file name with section subscript appended. + + header = immap (imagefile, READ_ONLY, 0) + + ncols = IM_LEN (header, 1) + nlines = IM_LEN (header, 2) + + # Read or map entire image into memory. Pixels are + # converted to type real if necessary. + + raster = imgs2r (header, 1, ncols, 1, nlines) + + # Call SPP or Fortran subroutine to process type real + # image. Note how the pointer "raster" is dereferenced. + + call subroutine (Memr[raster], ncols, nlines) + ... +.DE +.cs 1 + +.PP +Another, slightly different approach would be to allocate a single FIO +buffer and map it onto the entire file. This would require no modifications +to IMIO, rather one would modify the "file fault" code in FIO. +This scheme would more efficiently support random access (to image lines or +subrasters) on a virtual machine without introducing a real dependence +on virtual memory. diff --git a/sys/imio/iki/README b/sys/imio/iki/README new file mode 100644 index 00000000..14b0f3f5 --- /dev/null +++ b/sys/imio/iki/README @@ -0,0 +1,383 @@ + Image Kernel Interface (IKI) + Doug Tody + 08 May 1986 + + +1. INTRODUCTION + + The IKI is the interface between IMIO and some particular image storage +format. IMIO itself has no knowledge of the storage format. The primary +function of the IKI is to access image headers, mapping the host header +storage format into the IMIO image header descriptor and vice versa. +The IKI is responsible for all image management operations, including +opening/creating/updating headers, opening/creating pixfiles (pixel storage +files), deleting, renaming, and copying images, checking for the existence +of images, and so on. + +The IKI can support an arbitrary number of different storage formats. +Each format requires a set of format dependent driver subroutines implementing +the standard IKI functions. The IKI will dynamically select the driver to be +used to access a particular format at runtime. New drivers may be dynamically +loaded at runtime, in a way similar to that used for FIO. While IMIO directly +accesses the pixel storage file via binary FIO for efficiency reasons, the +pixfile is opened by the IKI driver, hence a special driver may be used if +desired. For example, this feature may be used to access image display frame +as a pixfile, or an image stored in archival format on an optical disk. + + +2. STRUCTURE + + The role played by the IKI and format specific IKI drivers in the image +i/o subsystem is illustrated in the figure below. + + + IMIO Format independent; primarily does i/o to + | the pixel file. The image header is read + | into a dynamically allocated descriptor at + | open time. + | + IKI Selects driver to be used. Maintains table + | of open images, handles cleanup during error + | recovery. + | + (drivers) Physically accesses/creates/deletes etc. an + image stored in a particular format. Maps + the header stored in some particular external + format into the standardized IMIO descriptor. + Responsible for opening/creating the pixfile, + returning a FIO file descriptor to IMIO, which + directly accesses the pixel data. + + +The format specific driver packages are written in SPP using only standard +VOS i/o facilities, e.g., FIO and MEMIO. This is necessary due to the use +of an SPP descriptor structure to maintain the incore version of the image +header, due to the need to return an FIO file descriptor to IMIO, and so on. +To add support for a new format, one need only add a new driver to the IKI +and relink the system. + + +3. LOGICAL SCHEMA + + The logical schema of the current IKI is highly constrained by the fact +that the IKI is an add-on to the existing IMIO interface. It is not worthwhile +in this revision to try to address the limitations/design flaws of the initial +IMIO interface, hence our intention is to add the IKI in such a way that few +changes are required to IMIO, and no changes are required to programs which +use IMIO. One or two further major revisions are planned before the final +interface is realized. The concept of the IKI is here to stay, but the current +interface attempts only to address the immediate need to support multiple +image formats with the least impact on current software. + +An image consists of a header and a pixel array stored in a random access +binary file. Images may be grouped together into an array or "cluster" of +images, with the individual images being accessed by a one indexed subscript +appended to the cluster name, e.g., "pix[3]" refers to image 3 of the cluster +"pix". To create a cluster containing more than one image a / followed by +the cluster size may be included in the cluster index, e.g., "pix[3/10]" to +create a cluster of 10 images and write into image 3. An image section may +optionally be appended to access some subset of the pixels in the image, e.g., +"pix[3][*,5]". Lastly, if the image is stored as a disk file, the filename +extension of the header file may be given to explicitly indicate the image +format (IKI driver) to be used to access the image. + +A full specification (referencing an existing image) might therefore be +"pix.hhh[3][*,5]", where the ".hhh" extension indicates that the cluster is +physically stored in an SDAS GEIS (group format) data structure, the "[3]" +indicates image 3, and the "[*,5]" is a conventional IMIO image section. +If the minimal specification "pix" were given, the IKI would determine that +"pix" was a GEIS format image, accessing the entire contents of image [1]. +As an aside, note that image sections are handled entirely by IMIO and are +not seen at the IKI level. Likewise, the cluster subscript is parsed by +IMIO and passed to the IKI as an integer argument. + + + IM_PIXTYPE int pixel type (usilrdx) + IM_NDIM int number of axes (0:7) + IM_LEN long[7] logical length of each axis (>=1) + IM_PHYSLEN long[7] physical length of each axis (>=1) + IM_CLINDEX int index of image in cluster + IM_CLSIZE int number of images in cluster + IM_PIXOFF long char file offset to the pixels + IM_CTIME long image creation time + IM_MTIME long most recent image modification time + IM_LIMTIME long time when max/min last updated + IM_MAX real maximum pixel value + IM_MIN real minimum pixel value + IM_PIXFILE char*80 pathname of pixel file (optional) + IM_TITLE char*80 image title string + + +The important fields of the IMIO image descriptor are summarized above, along +with their datatype and length in the case of arrays. This is from the original +IMIO design and has not been modified in any way, except for the addition of the +cluster fields to the runtime descriptor. The IKI drivers directly read and +write these fields in the image descriptor. + +In addition to these standard fields (for which the IKI driver must supply +reasonable values at open time) the image descriptor contains a "user area" +containing an arbitrary sequence of keyword=value parameters encoded in +FITS character format. The FITS cards are trimmed at the right and +concatenated into an EOS delimited string with newline characters delimiting +each card. All host format specific header parameters should be passed to +IMIO in the user area. In the case of group format images, the user area +will contain both the group parameters (parameters shared by the entire group +of images) and the group header parameters (parameters for the individual +image in the group specified at open time). IMIO makes no distinction +between the two types of parameters. All header parameters are available +to the high level applications code via the IMIO/IDBI interface. + + +4. IKI INTERFACE PROCEDURES + + The IMIO code calls only the IKI procedures and has no knowledge of the +IKI drivers, or of which driver has been connected to a particular image +descriptor. The high level IKI procedures are summarized below. The interface +is fairly small due to the use of the descriptor to maintain all information +describing the image, and due to the fact that IMIO directly accesses the +pixel data via FIO. + + + iki_open (im, image, group, gcount, acmode, o_im) + iki_close (im) + iki_opix (im) # open/create pixfile + iki_updhdr (im) # update image header + + iki_copy (oldname, newname) # fast copy of entire group + iki_delete (group) # delete entire group + iki_rename (oldname, newname) # rename entire group + + k = iki_access (image, acmode) # test existence, legal extn + iki_lddriver (open,close, # install new driver + opix,updhdr, access,copy,delete,rename) + + +The OPEN procedure opens or creates the indicated image in the named cluster. +In the case of a new image or new copy image, only the header is created by +the open call; the pixfile is not created until the OPIX routine is called, +allowing the high level code time to set the image dimensions, datatype, +number of groups, etc., in the image descriptor. Once OPIX has been called +to create a new group, the number of axes, size of each axis, pixel type, +etc. is fixed. + +In the case of image stored in the SDAS/GEIS group format, all of the images +in a cluster (group) must be of the same size, must have the same header +parameters, and the header parameters must be defined when the group is +created (new parameters or images cannot be added to the group later). +The first open call for a image will allocate space for all images in the +cluster, but only the indicated image will be initialized in the first call. +Multiple images may be simultaneously open in the same cluster, and the same +image may be multiply opened on independent logical FIO file descriptors. + +The high level IRAF software has little or no knowledge of the physical +association of images into clusters. In particular, the high level software +is ignorant about the SDAS/GEIS image storage format, but this need not +prevent processing of these images. The main limitations of the group +format derive from the fact that new images can neither be added to nor +deleted from to a group format cluster, and new parameters cannot be added +to a group header. To create a group format image via IMIO, one will normally +make a NEW_COPY copy of an existing group format image (to define the fields +of the group headers), specifing the number of images in the new group in +the cluster size field of the image name specification. For example, writing +to the new image "pix[3/10]" will cause a cluster of 10 images to be created +and image 3 to be initialized. Subsequent calls to write to either "pix[I]" +or "pix[I/10]" will be necessary to initialize the remaining images in the +cluster. + + +5. KERNEL PROCEDURES + + Each supported image format requires a dedicated set of kernel procedures +to be called by the IKI to access images stored in that format. The calling +sequences for these procedures are shown below. + + + xxx_open (im, root, extn, cl_index, cl_size, acmode, status) + xxx_close (im, status) + xxx_opix (im, status) + xxx_updhdr (im, status) + + xxx_access (root, extn, acmode, status) + xxx_copy (old_root, old_extn, new_root, new_extn, status) + xxx_delete (root, extn, status) + xxx_rename (old_root, old_extn, new_root, new_extn, status) + + +Here, the package prefix "xxx" is OIF for the old IRAF image format, and STF +for the STScI/SDAS GEIS format. Note that the OPEN procedure fills in selected +fields in a preallocated image descriptor rather than allocating the descriptor +itself. Image names are parsed into root, extension, cl_index, etc. fields by +the IKI or higher level code, to further simplify the kernel code. The IKI +verifies the existence or nonexistence of all operand images before calling +a kernel procedure, hence the kernel procedures need not perform these +functions. The kernel procedures should return an ERR status if they cannot +perform their function for some reason (rather than take an error action). +The locpr() entry point addresses of the kernel procedures are saved in a +runtime table maintained by the IKI. + +The syntax and semantics of the kernel procedures are discussed in detail below. +Since the interface routines have full access to the IMIO descriptors, it is +important to realize what does and does not have to be set. + + +5.1 IMAGE OPEN PRIMITIVE + +include <imhdr.h> +include <imio.h> +include "xxx.h" + +# XXX_OPEN -- Open/create an image. + +procedure oif_open (im, root, extn, cl_index, cl_size, acmode, status) + +pointer im # image descriptor (allocated by IMIO) +char root[ARB] # root image name +char extn[ARB] # extension, if any +int cl_index # index of image to be opened +int cl_size # number of images in cluster +int acmode # access mode +int status # return status (OK|ERR) + +begin + 1. Construct the filename of the header file and open or create the + image header file. + + 2. If opening an existing image, read the image header and fill in + the following fields of the IMIO image header descriptor. If + creating a new image set only the field IM_HDRFILE. + + IM_PIXTYPE # datatype of the pixels ** + IM_NDIM # number of dimensions ** + IM_LEN # length of the dimensions ** + + IM_CTIME # time of image creation + IM_MTIME # time of last modify + IM_LIMTIME # time min,max computed + IM_MAX # max pixel value + IM_MIN # min pixel value + IM_PIXFILE # name of pixel storage file + IM_HDRFILE # name of header storage file + IM_TITLE # image name string + IM_HISTORY # history comment string + + The really essential fields are marked with a ** at the right. + CTIME, PIXFILE, HDRFILE, TITLE, and HISTORY are for information + only. MTIME and LIMTIME are used to determine if the min/max + pixel values are up to date, and the actual values do not matter + provided the conclusion about the min/max values is correct. + + 3. If opening an existing image, call IMIO to set those fields of the + image header/descriptor describing the format in which the pixels + are stored in the pixel storage file. + + [] call imioff (im, pixoff, COMPRESS, blklen) + + where + pixoff FIO file offset of first pixel. + compress Set to NO to enable alignment of image + lines on block boundaries, to YES for + compressed byte stream image. + blklen Device block size, chars. Set to 1 to + defeat all block alignment. + + If opening a new image, this step may be left until the OPIX + primitive is called. + + 3. If the kernel procedures use their own internal descriptor, + allocate and initialize the descriptor and save a pointer to + it in IM_KDES(im). + + 4. Set return status. +end + + +5.2 OPEN PIXEL FILE PRIMITIVE + +include <imhdr.h> +include <imio.h> +include "xxx.h" + +# XXX_OPIX -- Open (or create) the pixel storage file. Call IMIO to set the +# file offsets and buffer sizes. + +procedure xxx_opix (im, status) + +pointer im # image descriptor +int status # return status + +begin + 1. Opening existing image: + 1.1 Open pixel file read only or read write. + + 2. Opening (creating) new image: + 2.1 Call IMIO to set the offset parameters, assuming this was not + already done in the OPEN primitive: + + [] call imioff (im, pixoff, COMPRESS, blklen) + + 2.2 Using the file size computed by imioff or determined by more + format specific means, open (falloc) the pixel storage file. + The IM_HGMOFF field of the image header is set by imioff + to the file offset of the end of the image. + + 3. Call IMIO to set the i/o buffer parameters: + + [] call imsetbuf (pfd, im) + + This sets the FIO buffer size and the IM_FAST parameter. + The buffer size should be set before doing any i/o on the + pixel file. If in doubt, skip the call and simply set + IM_FAST(im) = NO (i/o will be suboptimal but not too bad). + + 4. Save the pixfile FIO file descriptor (required for pixel i/o) + in the image descriptor: + + [] IM_PFD(im) = pfd +end + + +5.3 UPDATE HEADER PRIMITIVE + +include <imhdr.h> +include <imio.h> + +# XXX_UPDHDR -- Update the image header. + +procedure xxx_updhdr (im, status) + +pointer im # image descriptor +int status # return status + +begin + 1. Update the values of the standard logical image header fields + in the physical image header, e.g., PIXTYPE, NDIM, LEN, and CTIME + (for new images), MTIME, LIMTIME, MIN, MAX (any image). + + 2. Save the "user fields" in the physical image header. Some of + these may have been inserted in the user area by the kernel open + procedure, others may have been added by IRAF programs or by + the user since the image was opened. +end + + +5.4 CLOSE IMAGE PRIMITIVE + +include <imio.h> + +# XXX_CLOSE -- Close an image. + +procedure xxx_close (im, status) + +pointer im # image descriptor +int status + +begin + 1. If the pixel file has been opened, close it. Note that if no + pixel i/o was done to the image, the pixel file will never have + been opened. + + 2. If the header file is still open, close it. + + 3. If a special kernel descriptor was allocated at image open time + by the kernel, deallocate it. +end diff --git a/sys/imio/iki/fxf/Notes b/sys/imio/iki/fxf/Notes new file mode 100644 index 00000000..2a2fd74d --- /dev/null +++ b/sys/imio/iki/fxf/Notes @@ -0,0 +1,81 @@ +Fits kernel notes / unresolved issues +---------------------------------------------------------------------------- + +Extraneous env variables - put in fkinit + + ENV_DEFIMTYPE "imtype" + ENV_FITSCACHE "fitscache" + + +Rename + + minhdrlns + + +Cache + + hard upper limit - is this a restriction? + convert from common to dynamic descriptor + referenced: open delete rename rfits updhdr + +Extensions + should not use imtype to set extension (this is copied from STF which + also has the same problem) + +Defaults / ksection / fkinit + should overwrite be allowed in fkinit? (fxfopen) + +check on file clobber + + +---------------------------------------------------------------------------- +Extension, default image type + +imtype + The purpose of imtype is to control the types of images automatically + created by the system if no image extension is specified. + + new image - determines default image type + new copy - determines default image type if noinherit + no extn - up to kernel whether this is legal + + imtype = [(oif|fxf|plf|qpf|stf) | <any-valid-extn>] [[no]inherit] + + save format codes ("oif" etc) in driver descriptors + extensions are mapped to drivers using imextn + + +imextn + map file extensions to image type (kernel) + default extension for new images of a given type + + imextn = "oif:imh stf:hhh,??h fits:,fits,fit + + or possibly imextn = "imh:oif hhh,??h:stf fits,fit:fit + + kernels: oif fxf plf qpf stf + + iki_extninit (imtype, def_imtype, imextn, def_imextn) + iki_validextn (kernel, extn) + status = iki_getextn (kernel, index, extn, maxch) + + Initialize extension processing stuff at iki_init time - only once when + the process starts up. + + nextn + { kernel extn patbuf } + sbuf, sbufused + defimtype + inherit + +IKI - add kernel arg to: + access + copy + delete + open + rename + + + + + diff --git a/sys/imio/iki/fxf/README b/sys/imio/iki/fxf/README new file mode 100644 index 00000000..9c723b94 --- /dev/null +++ b/sys/imio/iki/fxf/README @@ -0,0 +1,5 @@ +# IKI/FXF -- Fits extension image kernel. +# There is a document describing the differents FK supported parameters: +# iraf.noao.edu/iraf/web/docs/fitsuserguide.html +# A PS file of this can be found in iraf.noao.edu/iraf/docs/fitsuserguide.ps.Z + diff --git a/sys/imio/iki/fxf/fxf.h b/sys/imio/iki/fxf/fxf.h new file mode 100644 index 00000000..c4e6188b --- /dev/null +++ b/sys/imio/iki/fxf/fxf.h @@ -0,0 +1,172 @@ +# FITS.H -- IKI/FITS internal definitions. + +define FITS_ORIGIN "NOAO-IRAF FITS Image Kernel July 2003" + +define FITS_LENEXTN 4 # max length imagefile extension +define SZ_DATATYPE 16 # size of datatype string (eg "REAL*4") +define SZ_EXTTYPE 20 # size of exttype string (eg BINTABLE) +define SZ_KEYWORD 8 # size of a FITS keyword +define SZ_EXTRASPACE (81*32) # extra space for new cards in header +define DEF_PHULINES 0 # initial allocation for PHU +define DEF_EHULINES 0 # initial allocation for EHU +define DEF_PADLINES 0 # initial value for extra lines in HU +define DEF_PLMAXLEN 32768 # default max PLIO encoded line length +define DEF_PLDEPTH 0 # default PLIO mask depth + +define FITS_BLOCK_BYTES 2880 # FITS logical block length (bytes) +define FITS_BLOCK_CHARS 1440 # FITS logical block length (spp chars) +define FITS_STARTVALUE 10 # first column of value field +define FITS_ENDVALUE 30 # last column of value field +define FITS_SZVALSTR 21 # nchars in value string +define LEN_CARD 80 # length of FITS card. +define LEN_UACARD 81 # size of a Userarea line. +define LEN_OBJECT 63 # maximum length of a FITS string value +define LEN_FORMAT 40 # maximum length of a TFORM value +define NO_KEYW -1 # indicates no keyword is present. + +define MAX_OFFSETS 100 # max number of offsets per cache entry. +define MAX_CACHE 60 # max number of cache entries. +define DEF_CACHE 10 # default number of cache entries. + +define DEF_HDREXTN "fits" # default header file extension +define ENV_FKINIT "fkinit" # FITS kernel initialization + +define DEF_ISOCUTOVER 0 # date when ISO format dates kick in +define ENV_ISOCUTOVER "isodates" # environment override for default + +define FITS_BYTE 8 # Bits in a FITS byte +define FITS_SHORT 16 # Bits in a FITS short +define FITS_LONG 32 # Bits in a FITS long +define FITS_REAL -32 # 32 Bits FITS IEEE float representation +define FITS_DOUBLE -64 # 64 Bits FITS IEEE double representation + +define COL_VALUE 11 # Starting column for parameter values +define NDEC_REAL 7 # Precision of real +define NDEC_DOUBLE 14 # Precision of double + +define FITS_LEN_CHAR (((($1) + 1439)/1440)* 1440) + +# Extension subtypes. +define FK_PLIO 1 + +# Mapping of FITS Keywords to IRAF image header. All unrecognized keywords +# are stored here. + +#define UNKNOWN Memc[($1+IMU-1)*SZ_MII_INT+1] +define UNKNOWN Memc[($1+IMU-1)*SZ_STRUCT+1] + + +# FITS image descriptor, used internally by the FITS kernel. The required +# header parameters are maintained in this descriptor, everything else is +# simply copied into the user area of the IMIO descriptor. + +define LEN_FITDES 500 +define LEN_FITBASE 400 + +define FIT_ACMODE Memi[$1] # image access mode +define FIT_PFD Memi[$1+1] # pixel file descriptor +define FIT_PIXOFF Memi[$1+2] # pixel offset +define FIT_TOTPIX Memi[$1+3] # size of image in pixfile, chars +define FIT_IO Memi[$1+4] # FITS I/O channel +define FIT_ZCNV Memi[$1+5] # set if on-the-fly conversion needed +define FIT_IOSTAT Memi[$1+6] # i/o status for zfio routines +define FIT_TFORMP Memi[$1+7] # TFORM keyword value pointer +define FIT_TTYPEP Memi[$1+8] # TTYPE keyword value pointer +define FIT_TFIELDS Memi[$1+9] # number of fields in binary table +define FIT_PCOUNT Memi[$1+10] # PCOUNT keyword value + # extra space +define FIT_BSCALE Memd[P2D($1+16)] +define FIT_BZERO Memd[P2D($1+18)] +define FIT_BITPIX Memi[$1+20] # bits per pixel +define FIT_NAXIS Memi[$1+21] # number of axes in image +define FIT_LENAXIS Memi[$1+22+$2-1]# 35:41 = [7] max +define FIT_ZBYTES Memi[$1+30] # Status value for FIT_ZCNV mode +define FIT_HFD Memi[$1+31] # Header file descriptor +define FIT_PIXTYPE Memi[$1+32] +define FIT_CACHEHDR Memi[$1+33] # Cached main header unit's address. +define FIT_CACHEHLEN Memi[$1+34] # Lenght of the above. +define FIT_IM Memi[$1+35] # Has the 'im' descriptor value +define FIT_GROUP Memi[$1+36] +define FIT_NEWIMAGE Memi[$1+37] # Newimage flag +define FIT_HDRPTR Memi[$1+38] # Header data Xtension pointer +define FIT_PIXPTR Memi[$1+39] # Pixel data Xtension pointer +define FIT_NUMOFFS Memi[$1+40] # Number of offsets in cache header. +define FIT_EOFSIZE Memi[$1+41] # Size in char of file before append. +define FIT_XTENSION Memi[$1+42] # Yes, if an Xtension has been read. +define FIT_INHERIT Memi[$1+43] # INHERIT header keyword value. +define FIT_EXTVER Memi[$1+44] # EXTVER value (integer only) +define FIT_EXPAND Memi[$1+45] # Expand the header? +define FIT_MIN Memr[P2R($1+46)]# Minimum pixel value +define FIT_MAX Memr[P2R($1+47)]# Maximum pixel value +define FIT_MTIME Meml[$1+48] # Time of last mod. for FITS unit +define FIT_SVNANR Memr[P2R($1+49)] +define FIT_SVNAND Memd[P2D($1+50)] +define FIT_SVMAPRIN Memi[$1+52] +define FIT_SVMAPROUT Memi[$1+53] +define FIT_SVMAPDIN Memi[$1+54] +define FIT_SVMAPDOUT Memi[$1+55] +define FIT_EXTEND Memi[$1+56] # FITS extend keyword +define FIT_PLMAXLEN Memi[$1+57] # PLIO maximum linelen + # extra space +define FIT_EXTTYPE Memc[P2C($1+70)] # extension type +define FIT_FILENAME Memc[P2C($1+110)] # FILENAME value +define FIT_EXTNAME Memc[P2C($1+150)] # EXTNAME value +define FIT_DATATYPE Memc[P2C($1+190)] # datatype string +define FIT_TITLE Memc[P2C($1+230)] # title string +define FIT_OBJECT Memc[P2C($1+270)] # object string +define FIT_EXTSTYPE Memc[P2C($1+310)] # FITS extension subtype + # extra space + +# The FKS terms carry the fkinit or kernel section arguments. +define FKS_APPEND Memi[$1+400] # YES, NO append an extension +define FKS_INHERIT Memi[$1+401] # YES, NO inherit the main header +define FKS_OVERWRITE Memi[$1+402] # YES, NO overwrite an extension +define FKS_DUPNAME Memi[$1+403] # YES, NO allow duplicated EXTNAME +define FKS_EXTVER Memi[$1+404] # YES, NO allow duplicated EXTNAME +define FKS_EXPAND Memi[$1+405] # YES, NO expand the header +define FKS_PHULINES Memi[$1+406] # Allocated lines in PHU +define FKS_EHULINES Memi[$1+407] # Allocated lines in EHU +define FKS_PADLINES Memi[$1+408] # Additional lines for HU +define FKS_NEWFILE Memi[$1+409] # YES, NO force newfile +define FKS_CACHESIZE Memi[$1+410] # size of header cache +define FKS_SUBTYPE Memi[$1+411] # BINTABLE subtype +define FKS_EXTNAME Memc[P2C($1+412)] # EXTNAME value + # extra space + + +# Reserved FITS keywords known to this code. + +define FK_KEYWORDS "|bitpix|datatype|end|naxis|naxisn|simple|bscale|bzero\ +|origin|iraf-tlm|filename|extend|irafname|irafmax|irafmin|datamax\ +|datamin|xtension|object|pcount|extname|extver|nextend|inherit\ +|zcmptype|tform|ttype|tfields|date|" + +define KW_BITPIX 1 +define KW_DATATYPE 2 +define KW_END 3 +define KW_NAXIS 4 +define KW_NAXISN 5 +define KW_SIMPLE 6 +define KW_BSCALE 7 +define KW_BZERO 8 +define KW_ORIGIN 9 +define KW_IRAFTLM 10 +define KW_FILENAME 11 +define KW_EXTEND 12 +define KW_IRAFNAME 13 +define KW_IRAFMAX 14 +define KW_IRAFMIN 15 +define KW_DATAMAX 16 +define KW_DATAMIN 17 +define KW_XTENSION 18 +define KW_OBJECT 19 +define KW_PCOUNT 20 +define KW_EXTNAME 21 +define KW_EXTVER 22 +define KW_NEXTEND 23 +define KW_INHERIT 24 +define KW_ZCMPTYPE 25 +define KW_TFORM 26 +define KW_TTYPE 27 +define KW_TFIELDS 28 +define KW_DATE 29 diff --git a/sys/imio/iki/fxf/fxfaccess.x b/sys/imio/iki/fxf/fxfaccess.x new file mode 100644 index 00000000..860724f0 --- /dev/null +++ b/sys/imio/iki/fxf/fxfaccess.x @@ -0,0 +1,59 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "fxf.h" + + +# FXF_ACCESS -- Test the accessibility or existence of an existing image, or +# the legality of the name of a new image. Returns status = YES or NO. + +procedure fxf_access (kernel, root, extn, acmode, status) + +int kernel #I IKI kernel +char root[ARB] #I root filename +char extn[ARB] #I extension (SET on output if none specified) +int acmode #I access mode (0 to test only existence) +int status #O status code + +int i +pointer sp, fname, kextn +int access(), iki_validextn(), iki_getextn(), btoi() + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + call salloc (kextn, FITS_LENEXTN, TY_CHAR) + + # If new image, test only the legality of the given extension. + # This is used to select a kernel given the imagefile extension. + + if (acmode == NEW_IMAGE || acmode == NEW_COPY) { + status = btoi (iki_validextn (kernel, extn) > 0) + call sfree (sp) + return + } + + status = NO + + # If no extension was given, look for a file with the default + # extension, and return the actual extension if an image with the + # default extension is found. + + if (extn[1] == EOS) { + do i = 1, ARB { + if (iki_getextn (kernel, i, Memc[kextn], FITS_LENEXTN) <= 0) + break + call iki_mkfname (root, Memc[kextn], Memc[fname], SZ_PATHNAME) + if (access (Memc[fname], acmode, 0) == YES) { + call strcpy (Memc[kextn], extn, FITS_LENEXTN) + status = YES + break + } + } + } else if (iki_validextn (kernel, extn) == kernel) { + call iki_mkfname (root, extn, Memc[fname], SZ_PATHNAME) + if (access (Memc[fname], acmode, 0) == YES) + status = YES + } + + call sfree (sp) +end diff --git a/sys/imio/iki/fxf/fxfaddpar.x b/sys/imio/iki/fxf/fxfaddpar.x new file mode 100644 index 00000000..ce7849f5 --- /dev/null +++ b/sys/imio/iki/fxf/fxfaddpar.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> +include <mach.h> +include "fxf.h" + +# FXF_ADDPAR -- Encode a parameter in FITS format and add it to the FITS format +# IMIO userarea. + +procedure fxf_addpar (im, pname, dtype, pval) + +pointer im #I image descriptor +char pname[ARB] #I parameter name +int dtype #I SPP datatype of parameter +char pval[ARB] #I string encoded parameter value + +bool bval +real rval +double dval +short sval +long lval +int ival, ip, junk +int ctoi(), ctor(), ctod() +errchk imadds, imaddl, imaddr, imaddd, imastr + +begin + ip = 1 + + switch (dtype) { + case TY_BOOL: + bval = (pval[1] == 'T') + call imaddb (im, pname, bval) + case TY_SHORT: + junk = ctoi (pval, ip, ival) + sval = ival + call imadds (im, pname, sval) + case TY_INT, TY_LONG: + junk = ctoi (pval, ip, ival) + lval = ival + call imaddl (im, pname, lval) + case TY_REAL: + junk = ctor (pval, ip, rval) + call imaddr (im, pname, rval) + case TY_DOUBLE: + junk = ctod (pval, ip, dval) + call imaddd (im, pname, dval) + default: + call imastr (im, pname, pval) + } +end diff --git a/sys/imio/iki/fxf/fxfcache.com b/sys/imio/iki/fxf/fxfcache.com new file mode 100644 index 00000000..c38317aa --- /dev/null +++ b/sys/imio/iki/fxf/fxfcache.com @@ -0,0 +1,24 @@ +# FXFCACHE.COM -- Named common block used to cache filenames and image +# extension information. +# +# ##### This should be reimplemented to use a small package (i.e. functions) +# ##### rather than global common. rf_fname below is using a lot of memory. +# ##### Dynamic memory allocation or a packed string buffer should be used +# ##### instead. Not worth fixing though until the cache code is redone. + +int rf_cachesize +pointer rf_fit[MAX_CACHE] # FITS descriptor +pointer rf_hdrp[MAX_CACHE] # Fits headers pointer +pointer rf_pixp[MAX_CACHE] # Fits pixels pointer +pointer rf_pextn[MAX_CACHE] # EXTNAME pointer +pointer rf_pextv[MAX_CACHE] # EXTVER pointer +int rf_lru[MAX_CACHE] # Lowest value is oldest slot +long rf_time[MAX_CACHE] # Time when entry was cached +long rf_mtime[MAX_CACHE] # Modify time of file in cache +int rf_hdr[MAX_CACHE] # FITS Primary header data +int rf_fitslen[MAX_CACHE] # Size Primary header data +char rf_fname[SZ_PATHNAME,MAX_CACHE] # Header file pathname + +common /fxflcachec/ rf_time, rf_mtime +common /fxfcachec/ rf_cachesize, rf_fit, rf_hdrp, rf_pixp, rf_pextn, + rf_pextv, rf_lru, rf_hdr, rf_fitslen, rf_fname diff --git a/sys/imio/iki/fxf/fxfclose.x b/sys/imio/iki/fxf/fxfclose.x new file mode 100644 index 00000000..72313316 --- /dev/null +++ b/sys/imio/iki/fxf/fxfclose.x @@ -0,0 +1,42 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> +include "fxf.h" + +# FXF_CLOSE -- Close a FITS format image. There is little for us to do, since +# IMIO will already have updated the header if necessary and flushed any pixel +# output. Neither do we have to deallocate the IMIO descriptor, since it was +# allocated by IMIO. + +procedure fxf_close (im, status) + +pointer im #I image descriptor +int status #O status value + +pointer fit +errchk close + +begin + fit = IM_KDES(im) + + # Reset the IEEE interface to its original state. + switch (IM_ACMODE(im)) { + case READ_ONLY, READ_WRITE, WRITE_ONLY: + call ieesnanr (FIT_SVNANR(fit)) + call ieesmapr (FIT_SVMAPRIN(fit), FIT_SVMAPROUT(fit)) + call ieesnand (FIT_SVNAND(fit)) + call ieesmapd (FIT_SVMAPDIN(fit), FIT_SVMAPDOUT(fit)) + default: + ; + } + + # Close the fits file. + if (IM_PFD(im) != NULL) + call close (IM_PFD(im)) + + # Deallocate the FIT descriptor. + call mfree (fit, TY_STRUCT) + + status = OK +end diff --git a/sys/imio/iki/fxf/fxfcopy.x b/sys/imio/iki/fxf/fxfcopy.x new file mode 100644 index 00000000..3fb4d51b --- /dev/null +++ b/sys/imio/iki/fxf/fxfcopy.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> + +# FXF_COPY -- Copy an image. A special operator is provided for fast, blind +# copies of entire images. + +procedure fxf_copy (kernel, oroot, oextn, nroot, nextn, status) + +int kernel #I IKI kernel +char oroot[ARB] #I old image root name +char oextn[ARB] #I old image extn +char nroot[ARB] #I new image root name +char nextn[ARB] #I old image extn +int status + +pointer sp +pointer ohdr_fname, nhdr_fname + +begin + call smark (sp) + call salloc (ohdr_fname, SZ_PATHNAME, TY_CHAR) + call salloc (nhdr_fname, SZ_PATHNAME, TY_CHAR) + + # Generate filenames. + call iki_mkfname (oroot, oextn, Memc[ohdr_fname], SZ_PATHNAME) + call iki_mkfname (nroot, nextn, Memc[nhdr_fname], SZ_PATHNAME) + + iferr (call fcopy (Memc[ohdr_fname], Memc[nhdr_fname])) + call erract (EA_WARN) + + call sfree (sp) + status = OK +end diff --git a/sys/imio/iki/fxf/fxfctype.x b/sys/imio/iki/fxf/fxfctype.x new file mode 100644 index 00000000..f916e344 --- /dev/null +++ b/sys/imio/iki/fxf/fxfctype.x @@ -0,0 +1,72 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <ctype.h> +include "fxf.h" + + +# FXF_CTYPE -- Determine the type of a FITS card. + +int procedure fxf_ctype (card, kwindex) + +char card[ARB] #I FITS card (or keyword) +int kwindex #O index number, if any + +pointer sp, kwname +char kw[SZ_KEYWORD] +int index, ch, i, ip +int strncmp(), strdic(), strlen(), ctoi() +string keywords FK_KEYWORDS + +begin + call smark (sp) + call salloc (kwname, LEN_CARD, TY_CHAR) + + # Check for a reference to one of the NAXIS keywords. + kwindex= 0 + if (card[1] == 'N') + if (strncmp (card, "NAXIS", 5) == 0) { + ch = card[6] + if (ch == EOS || (IS_DIGIT(ch) && card[7] == ' ')) { + kwindex = TO_INTEG(ch) + } + call sfree (sp) + return (KW_NAXIS) + } + + # See if it is one of the "T"-prefixed (binary table) keywords. + if (card[1] == 'T') { + ip = 6 + if (strncmp (card, "TFORM", 5) == 0) { + if (ctoi (card, ip, kwindex) < 1) + kwindex = 0 + call sfree (sp) + return (KW_TFORM) + } + if (strncmp (card, "TTYPE", 5) == 0) { + if (ctoi (card, ip, kwindex) < 1) + kwindex = 0 + call sfree (sp) + return (KW_TTYPE) + } + } + + # Get keyword name in lower case with no blanks. + do i = 1, SZ_KEYWORD { + if (IS_WHITE(card[i])) { + kw[i] = EOS + break + } else if (IS_UPPER(card[i])) + kw[i] = TO_LOWER (card[i]) + else + kw[i] = card[i] + } + + # Look up keyword in dictionary. Abbreviations are not permitted. + index = strdic (kw, Memc[kwname], LEN_CARD, keywords) + if (index != 0) + if (strlen(kw) != strlen(Memc[kwname])) + index = 0 + + call sfree (sp) + return (index) +end diff --git a/sys/imio/iki/fxf/fxfdelete.x b/sys/imio/iki/fxf/fxfdelete.x new file mode 100644 index 00000000..ae7fbffc --- /dev/null +++ b/sys/imio/iki/fxf/fxfdelete.x @@ -0,0 +1,74 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <error.h> +include <imhdr.h> +include "fxf.h" + +# FXF_DELETE -- Delete a FITS file. NOTE: it is not possible to delete an +# individual extension at this time. + +procedure fxf_delete (kernel, root, extn, status) + +int kernel #I IKI kernel +char root[ARB] #I root filename +char extn[ARB] #I header file extension +int status #O status value + +int cindx +pointer sp, fname, im, tmp +pointer immapz() +bool streq() + +errchk syserrs +include "fxfcache.com" + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + call salloc (tmp, SZ_PATHNAME, TY_CHAR) + + call fxf_init() + status = OK + + # Get the file extension if not given. + if (extn[1] == EOS) { + call fxf_access (kernel, root, extn, READ_ONLY, status) + if (status == NO) { + call sfree (sp) + status = ERR + return + } + } + + call iki_mkfname (root, extn, Memc[fname], SZ_PATHNAME) + call strcpy (Memc[fname], Memc[tmp], SZ_PATHNAME) + call strcat ("[0]", Memc[tmp], SZ_PATHNAME) + iferr (im = immapz (Memc[tmp], READ_ONLY, 0)) + call syserrs (SYS_FXFDELMEF, Memc[fname]) + else + call imunmap (im) + + iferr (call delete (Memc[fname])) + call erract (EA_WARN) + + # Remove the image from the FITS cache if found. + do cindx=1, rf_cachesize { + if (rf_fit[cindx] == NULL) + next + if (streq (Memc[fname], rf_fname[1,cindx])) { + call mfree (rf_pextv[cindx], TY_INT) + call mfree (rf_pextn[cindx], TY_CHAR) + call mfree (rf_pixp[cindx], TY_INT) + call mfree (rf_hdrp[cindx], TY_INT) + call mfree (rf_fit[cindx], TY_STRUCT) + call mfree (rf_hdr[cindx], TY_CHAR) + rf_fit[cindx] = NULL + rf_lru[cindx] = 0 + rf_fname[1,cindx] = EOS + } + } + + status = OK + call sfree (sp) +end diff --git a/sys/imio/iki/fxf/fxfencode.x b/sys/imio/iki/fxf/fxfencode.x new file mode 100644 index 00000000..ea2e83dd --- /dev/null +++ b/sys/imio/iki/fxf/fxfencode.x @@ -0,0 +1,348 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <time.h> +include "fxf.h" + +# FXFENCODE.X -- Routines to encode a keyword, its value and a comment into +# a FITS card. +# +# fxf_encode_axis (root, keyword, axisno) +# fxf_encode_date (ctime, datestr, szdate, format, cutover) +# +# fxf_encodeb (keyword, param, card, comment) +# fxf_encodei (keyword, param, card, comment) +# fxf_encodel (keyword, param, card, comment) +# fxf_encoder (keyword, param, card, comment, precision) +# fxf_encoded (keyword, param, card, comment, precision) +# fxf_encodec (keyword, param, maxch, card, comment) +# +# fxf_akwc (keyword, value, len, comment, pn) +# fxf_akwb (keyword, value, comment, pn) +# fxf_akwi (keyword, value, comment, pn) +# fxf_akwr (keyword, value, comment, precision, pn) +# fxf_akwd (keyword, value, comment, precision, pn) +# +# Encode_axis adds an axis number to a keyword ("rootXXX"). Encode_date +# encodes the current date as a string in the form "dd/mm/yy". + + +# FXF_ENCODEB -- Encode a boolean parameter into a FITS card. + +procedure fxf_encodeb (keyword, param, card, comment) + +char keyword[ARB] # FITS keyword +int param # integer parameter equal to YES/NO +char card[ARB] # FITS card image +char comment[ARB] # FITS comment string + +char truth + +begin + if (param == YES) + truth = 'T' + else + truth = 'F' + + call sprintf (card, LEN_CARD, "%-8.8s= %20c / %-47.47s") + call pargstr (keyword) + call pargc (truth) + call pargstr (comment) +end + + +# FXF_ENCODEI -- Encode an integer parameter into a FITS card. + +procedure fxf_encodei (keyword, param, card, comment) + +char keyword[ARB] # FITS keyword +int param # integer parameter +char card[ARB] # FITS card image +char comment[ARB] # FITS comment string + +begin + call sprintf (card, LEN_CARD, "%-8.8s= %20d / %-47.47s") + call pargstr (keyword) + call pargi (param) + call pargstr (comment) +end + + +# FXF_ENCODEL -- Encode a long parameter into a FITS card. + +procedure fxf_encodel (keyword, param, card, comment) + +char keyword[ARB] # FITS keyword +long param # long integer parameter +char card[ARB] # FITS card image +char comment[ARB] # FITS comment string + +begin + call sprintf (card, LEN_CARD, "%-8.8s= %20d / %-47.47s") + call pargstr (keyword) + call pargl (param) + call pargstr (comment) +end + + +# FXF_ENCODER -- Encode a real parameter into a FITS card. + +procedure fxf_encoder (keyword, param, card, comment, precision) + +char keyword[ARB] # FITS keyword +real param # real parameter +char card[ARB] # FITS card image +char comment[ARB] # FITS comment card +int precision # precision of real + +begin + call sprintf (card, LEN_CARD, "%-8.8s= %20.*e / %-47.47s") + call pargstr (keyword) + call pargi (precision) + call pargr (param) + call pargstr (comment) +end + + +# FXF_ENCODED -- Encode a double parameter into a FITS card. + +procedure fxf_encoded (keyword, param, card, comment, precision) + +char keyword[ARB] # FITS keyword +double param # double parameter +char card[ARB] # FITS card image +char comment[ARB] # FITS comment string +int precision # FITS precision + +begin + call sprintf (card, LEN_CARD, "%-8.8s= %20.*e / %-47.47s") + call pargstr (keyword) + call pargi (precision) + call pargd (param) + call pargstr (comment) +end + + +# FXF_ENCODE_AXIS -- Add the axis number to axis dependent keywords. + +procedure fxf_encode_axis (root, keyword, axisno) + +char root[ARB] # FITS root keyword +char keyword[ARB] # FITS keyword +int axisno # FITS axis number + +int len, strlen() + +begin + call strcpy (root, keyword, SZ_KEYWORD) + len = strlen (keyword) + call sprintf (keyword, SZ_KEYWORD, "%*.*s%d") + call pargi (-len) + call pargi (len) + call pargstr (root) + call pargi (axisno) +end + + +# FXF_ENCODEC -- Procedure to encode an IRAF string parameter into a FITS card. + +procedure fxf_encodec (keyword, param, maxch, card, comment) + +char keyword[LEN_CARD] # FITS keyword +char param[LEN_CARD] # FITS string parameter +int maxch # maximum chars in value string +char card[LEN_CARD+1] # FITS card image +char comment[LEN_CARD] # comment string + +int nblanks, maxchar, slashp + +begin + maxchar = max(8, min (maxch, LEN_OBJECT)) + slashp = 32 + nblanks = LEN_CARD - (slashp + 1) + if (maxchar >= 19) { + slashp = 1 + nblanks = max (LEN_OBJECT - maxchar - slashp+3, 1) + } + + call sprintf (card, LEN_CARD, "%-8.8s= '%*.*s' %*t/ %*.*s") + call pargstr (keyword) + call pargi (-maxchar) + call pargi (maxchar) + call pargstr (param) + call pargi (slashp) + call pargi (-nblanks) + call pargi (nblanks) + call pargstr (comment) +end + + +# FXF_ENCODE_DATE -- Encode the current date as a string value. +# +# New Y2K format: yyyy-mm-ddThh:mm:sec +# Old FITS format: dd/mm/yy +# Old TLM format: hh:mm:ss (dd/mm/yyyy) +# +# We still write the old format for dates 1999 or less. + +procedure fxf_encode_date (ctime, datestr, maxch, format, cutover) + +long ctime #I time value to be encoded +char datestr[ARB] #O string containing the date +int maxch #I number of chars in the date string +char format[ARB] #I desired date format for old dates +int cutover #I write new format for years >= cutover + +int tm[LEN_TMSTRUCT], nchars +int dtm_encode_hms() +long lsttogmt() +bool streq() + +begin + # Find out what year it is. + call brktime (ctime, tm) + + # Encode in ISO format for years >= cutover year. + + if (TM_YEAR(tm) >= cutover) { + # ISO format is used for all new date stamps. + call brktime (lsttogmt(ctime), tm) + nchars = dtm_encode_hms (datestr, maxch, + TM_YEAR(tm), TM_MONTH(tm), TM_MDAY(tm), + TM_HOUR(tm), TM_MIN(tm), double(TM_SEC(tm)), 0, 0) + + } else if (streq (format, "TLM")) { + # TLM format is for old-format DATE-TLM keywords. + call sprintf (datestr, maxch, "%02d:%02d:%02d (%02d/%02d/%d)") + call pargi (TM_HOUR(tm)) + call pargi (TM_MIN(tm)) + call pargi (TM_SEC(tm)) + call pargi (TM_MDAY(tm)) + call pargi (TM_MONTH(tm)) + call pargi (TM_YEAR(tm)) + + } else { + # The default otherwise is the old FITS format. + call sprintf (datestr, maxch, "%02d/%02d/%02d") + call pargi (TM_MDAY(tm)) + call pargi (TM_MONTH(tm)) + call pargi (mod(TM_YEAR(tm),100)) + + } +end + + +# FXF_AKWC -- Encode keyword, value and comment into a FITS card and +# append it to a buffer pointed by pn. + +procedure fxf_akwc (keyword, value, len, comment, pn) + +char keyword[SZ_KEYWORD] # keyword name +char value[ARB] # keyword value +int len # length of value +char comment[ARB] # comment +pointer pn # pointer to a char area +char card[LEN_CARD] + +begin + call fxf_encodec (keyword, value, len, card, comment) + call amovc (card, Memc[pn], LEN_CARD) + pn = pn + LEN_CARD +end + + +# FXF_AKWB -- Encode keyword, value and comment into a FITS card and +# append it to a buffer pointed by pn. + +procedure fxf_akwb (keyword, value, comment, pn) + +char keyword[SZ_KEYWORD] # I keyword name +int value # I Keyword value (YES, NO) +char comment[ARB] # I Comment +pointer pn # I/O Pointer to a char area + +pointer sp, pc + +begin + call smark (sp) + call salloc (pc, LEN_CARD, TY_CHAR) + + call fxf_encodeb (keyword, value, Memc[pc], comment) + call amovc (Memc[pc], Memc[pn], LEN_CARD) + pn = pn + LEN_CARD + + call sfree (sp) +end + + +# FXF_AKWI -- Encode keyword, value and comment into a FITS card and +# append it to a buffer pointed by pn. + +procedure fxf_akwi (keyword, value, comment, pn) + +char keyword[SZ_KEYWORD] # I keyword name +int value # I Keyword value +char comment[ARB] # I Comment +pointer pn # I/O Pointer to a char area + +pointer sp, pc + +begin + call smark (sp) + call salloc (pc, LEN_CARD, TY_CHAR) + + call fxf_encodei (keyword, value, Memc[pc], comment) + call amovc (Memc[pc], Memc[pn], LEN_CARD) + pn = pn + LEN_CARD + + call sfree (sp) +end + + +# FXF_AKWR -- Encode keyword, value and comment into a FITS card and +# append it to a buffer pointed by pn. + +procedure fxf_akwr (keyword, value, comment, precision, pn) + +char keyword[SZ_KEYWORD] # I keyword name +real value # I Keyword value +char comment[ARB] # I Comment +int precision +pointer pn # I/O Pointer to a char area + +pointer sp, pc + +begin + call smark (sp) + call salloc (pc, LEN_CARD, TY_CHAR) + + call fxf_encoder (keyword, value, Memc[pc], comment, precision) + call amovc (Memc[pc], Memc[pn], LEN_CARD) + pn = pn + LEN_CARD + + call sfree (sp) +end + + +# FXF_AKWD -- Encode keyword, value and comment into a FITS card and +# append it to a buffer pointed by pn. + +procedure fxf_akwd (keyword, value, comment, precision, pn) + +char keyword[SZ_KEYWORD] # I keyword name +double value # I Keyword value +char comment[ARB] # I Comment +int precision +pointer pn # I/O Pointer to a char area + +pointer sp, pc + +begin + call smark (sp) + call salloc (pc, LEN_CARD, TY_CHAR) + + call fxf_encoded (keyword, value, Memc[pc], comment, precision) + call amovc (Memc[pc], Memc[pn], LEN_CARD) + pn = pn + LEN_CARD + + call sfree (sp) +end diff --git a/sys/imio/iki/fxf/fxfexpandh.x b/sys/imio/iki/fxf/fxfexpandh.x new file mode 100644 index 00000000..9e00d582 --- /dev/null +++ b/sys/imio/iki/fxf/fxfexpandh.x @@ -0,0 +1,375 @@ +include <imio.h> +include <imhdr.h> +include <mii.h> +include <fset.h> +include <mach.h> +include <syserr.h> +include "fxf.h" + +define MIN_BUFSIZE 2880 + + +# FXF_EXPANDH -- Routine to expand all the headers of a MEF file. The calling +# routine only requires that extension 'group' be expanded but when dealing +# with large MEF files with many extensions this procedure can take a long +# time if the application code wants to expand more than one header. +# fxf_expandh will expand all the headers in the file so they will have at +# least 'nlines' blank cards. + +procedure fxf_expandh (in_fd, out_fd, nlines, group, nbks, hdroff, pixoff) + +int in_fd #I input file descriptor +int out_fd #I output file descriptor +int nlines #I minimum number of blank cards +int group #I group that initiated the expansion +int nbks #I numbers of blocks to expand group 'group' +int hdroff #O new offset for beginning of 'group' +int pixoff #0 new offset for beginning of data + +pointer hd, ip, op, buf +char line[80], endl[80] +int gn, newc, k, nchars, nbk, hsize +int fxf_xaddl(), read() + +int bufsize, psize, rem, hoffset, poffset +int note(), fstati() +errchk malloc, read, write + +begin + # In case nlines is zero set a minimum > 0. + nlines = max (nlines, 10) + + # Initialize a blank line. + call amovks (" ", line, LEN_CARD) + + # Initialize END card image. + call amovc ("END", endl, 3) + call amovks (" ", endl[4], LEN_CARD-3) + + call fseti (in_fd, F_ADVICE, SEQUENTIAL) + call fseti (out_fd, F_ADVICE, SEQUENTIAL) + + bufsize = max (MIN_BUFSIZE, fstati (in_fd, F_BUFSIZE)) + call malloc (buf, bufsize, TY_CHAR) + + gn = 0 + hd = buf + + repeat { + hd = buf + if (group == gn) + hdroff = note(out_fd) + + # Read and write header information. The last block must + # have the END card and is output from this routine. + + iferr (call fxf_xhrd (in_fd, out_fd, Memc[buf], bufsize, hoffset, + poffset, hsize)) + break + + # Determine the number of cards to expand. newc is in blocks + # of 36 cards. 0, 36, 72, ... + + newc = fxf_xaddl (buf, hsize, nlines) + + # expand the given group at least one block + if (newc == 0 && nbks > 0 && group == gn) + newc = nbks * 36 + + # OP points to the top of the last block read, IP to the bottom. + op = buf + hsize - FITS_BLOCK_BYTES + ip = buf + hsize + + if (newc == 0) { + # Leave space for the END card. + ip = ip - 80 + } else { + # Write current buffer before writing blanks. + call miipak (Memc[op], Memc[op], FITS_BLOCK_BYTES, + TY_CHAR,MII_BYTE) + call write (out_fd, Memc[op], FITS_BLOCK_CHARS) + + # Use the same buffer space since we are using blanks + ip = ip - FITS_BLOCK_BYTES + op = ip + } + + # Write the blank cards. + do k = 1, newc-1 { + call amovc (line, Memc[ip], LEN_CARD) + ip = ip + LEN_CARD + if (mod (k,36) == 0) { + # We have more than one block of blanks. + call miipak (Memc[op], Memc[op], nchars, TY_CHAR, MII_BYTE) + call write (out_fd, Memc[op], FITS_BLOCK_CHARS) + + # Notice we used the same buffer space + ip = ip - FITS_BLOCK_BYTES + op = ip + } + } + + # Finally the END card. + call amovc (endl, Memc[ip], LEN_CARD) + nchars = 2880 + call miipak (Memc[op], Memc[op], nchars, TY_CHAR, MII_BYTE) + call write (out_fd, Memc[op], nchars/2) + + # Get the number of blocks of pixel data to copy. We are not + # changing anything; it is straight copy. + + psize = (hoffset - poffset) + + nbk = psize / bufsize + rem = mod(psize,bufsize) + + if (group == gn) + pixoff = note(out_fd) + + do k = 1, nbk { + nchars = read (in_fd, Memc[buf], bufsize) + call write (out_fd, Memc[buf], bufsize) + } + if (rem > 0) { + nchars = read (in_fd, Memc[buf], rem) + call write (out_fd, Memc[buf], rem) + } + gn = gn + 1 + } + + call mfree (buf, TY_CHAR) +end + + +# FXF_XHRD -- Procedure to read 2880 bytes blocks of header from 'in' +# and copy them to 'out'. The last block read contains the END card +# and is pass to the calling routine which will write it out to 'out. + +procedure fxf_xhrd (in, out, buf, bufsize, hoffset, poffset, hsize) + +int in #I Input file descriptor +int out #I output file descriptor +char buf[ARB] #I Working buffer +int bufsize #I Workign buffer size +int hoffset #O Header offset for next group +int poffset #O Data offset for current group +int hsize #O Number of cards read in header + +pointer sp, hb +int nblks, totpix, i, j, ip, nchars +int strncmp(), note(), read() +bool end_card, fxf_xn_decode_blk1() + +include "fxfcache.com" +errchk syserr, read, write + +begin + call smark (sp) + call salloc (hb, 1440, TY_CHAR) + + hoffset = note (in) + + # Read first block of header. + nchars = read (in, Memc[hb], FITS_BLOCK_CHARS) + if (nchars == EOF) { + call sfree (sp) + call syserr (SYS_FXFRFEOF) + } + + call miiupk (Memc[hb], buf, FITS_BLOCK_BYTES, MII_BYTE,TY_CHAR) + end_card = fxf_xn_decode_blk1 (buf, totpix) + if (!end_card) { + call miipak (buf, Memc[hb], FITS_BLOCK_BYTES, TY_CHAR, MII_BYTE) + call write (out, Memc[hb], FITS_BLOCK_CHARS) + } + ip = FITS_BLOCK_BYTES + 1 + + nblks = 1 + if (!end_card) { + # Continue reading header until the block with END + # which is the last before the data block. + + while (read (in, Memc[hb], FITS_BLOCK_CHARS) != EOF) { + call miiupk (Memc[hb], buf[ip], FITS_BLOCK_BYTES, + MII_BYTE,TY_CHAR) + + # Look for the END card + do i = 0, 35 { + j = ip + i*LEN_CARD + if (buf[j] == 'E') { + if (strncmp (buf[j], "END ", 8) == 0) + end_card = true + } + } + nblks = nblks + 1 + if (end_card) + break + call miipak (buf[ip], Memc[hb], FITS_BLOCK_BYTES, + TY_CHAR, MII_BYTE) + call write (out, Memc[hb], FITS_BLOCK_CHARS) + ip = ip + FITS_BLOCK_BYTES + + # If the header is really big we can run out of + # buffer space. Revert back to the beginning. + + if (ip > bufsize) { + ip = 1 + nblks = 1 + } + } + } + + hsize = nblks * 36 * LEN_CARD + + # We are at the beginning of the pixel area. + poffset = note (in) + + # Get the beginnning of the next header. + hoffset = poffset + totpix + + call sfree (sp) +end + + +# FXF_XN_DECODE_BLK1 -- Function that return true if the 1st block of a header +# contains the END card. The size of the pixel are is also returned. + +bool procedure fxf_xn_decode_blk1 (buf, datalen) + +char buf[ARB] #I header data buffer +int datalen #O length of data area in chars + +char card[LEN_CARD] +int totpix, nbytes, index, k, i, pcount, bitpix, naxis, ip +int len_axis[7] +int fxf_ctype() +bool end_card +errchk syserr, syserrs + +begin + # Read successive lines of the 1st header block + pcount = 0 + + end_card = false + do k = 0, 35 { + ip = k*LEN_CARD + 1 + + # Copy into a one line buffer, we need to EOS mark. + call strcpy (buf[ip], card, LEN_CARD) + switch (fxf_ctype (card, index)) { + case KW_END: + end_card = true + break + case KW_PCOUNT: + call fxf_geti (card, pcount) + case KW_BITPIX: + call fxf_geti (card, bitpix) + case KW_NAXIS: + if (index == 0) { + call fxf_geti (card, naxis) + if (naxis < 0 ) + call syserr (SYS_FXFRFBNAXIS) + } else + call fxf_geti (card, len_axis[index]) + default: + ; + } + } + + # Calculate the length of the data area of the current extension, + # measured in SPP chars and rounded up to an integral number of FITS + # logical blocks. + + if (naxis != 0) { + totpix = len_axis[1] + do i = 2, naxis + totpix = totpix * len_axis[i] + + # Compute the size of the data area (pixel matrix plus PCOUNT) + # in bytes. Be careful not to overflow a 32 bit integer. + + nbytes = (totpix + pcount) * (abs(bitpix) / NBITS_BYTE) + + # Round up to fill the final 2880 byte FITS logical block. + nbytes = ((nbytes + 2880-1) / 2880) * 2880 + + datalen = nbytes / SZB_CHAR + + } else + datalen = 0 + + return (end_card) +end + + +# FXF_XADDL -- Algorithm to find the number of blank cards stored in the +# input buffer. This is the number from the end of the buffer up to the +# last non blank card (excluding the END card). The function returns the +# number of extra header cards (in multiple of 36) that is necessary to +# add to the current header. + +int procedure fxf_xaddl (hd, ncua, nlines) + +pointer hd #U header area pointer +int ncua #I number of characters in the user area +int nlines #I minimum number of header lines to be added + +int ip, nbc, k, ncards, nkeyw +int strncmp() + +begin + # Go to the end of buffer and get last line pointer + ip = hd + ncua - LEN_CARD + + # See if line is blank. + nbc = 0 + while (ip > hd) { + # Check for nonblank card + do k = 0, LEN_CARD-1 + if (Memc[ip+k] != ' ') + break + + # Since we are counting from the bottom, the first keyword + # (except END) would end counting. + + if (k != LEN_CARD && k != 0) # nonblank keyw card reached + break + else if (k == 0) { + # Just bypass END and continue looking for blank cards + if (strncmp ("END ", Memc[ip], 8) == 0) { + # Clear this card as it will be written at the + # end of the output header. + call amovkc (" ", Memc[ip], LEN_CARD) + ip = ip - LEN_CARD + next + } else + break + } else + nbc = nbc + 1 + ip = ip - LEN_CARD + } + + # Calculate the number of keywords right before the last blank + # card and right after the last non-blank keyword, excluding the + # END card + + nkeyw = (ip-hd)/80 + 1 + + ncards = ncua / LEN_CARD + + # Calculate the complement with respect to 36 + ncards = ((ncards + 35)/36)*36 - ncards + nbc = nbc + ncards + + + if (nbc < nlines) { + # Lets add nlines-nbc cards to the header + ncards = nlines - nbc + + # Adjust to a 36 cards boundary. + ncards = 36 - mod (ncards, 36) + ncards + } else + ncards = 0 + + return (ncards) +end diff --git a/sys/imio/iki/fxf/fxfget.x b/sys/imio/iki/fxf/fxfget.x new file mode 100644 index 00000000..87b80d4f --- /dev/null +++ b/sys/imio/iki/fxf/fxfget.x @@ -0,0 +1,182 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <ctype.h> +include "fxf.h" + +# FXFGET.X -- Procedures used to get (decode) typed values from FITS cards. +# +# fxf_get[bird] (card, value) +# fxf_gstr (card, outstr, maxch) +# fxf_getcmt (card, comment, maxch) +# fxf_gltm (time, date, limtime) +# +# The value is returned in the output argument. Zero is returned if the +# conversion fails. + + +# FXF_GETI -- Return the integer value of a FITS encoded card. + +procedure fxf_geti (card, ival) + +char card[ARB] # card to be decoded +int ival # receives integer value + +int ip, ctoi() +char sval[FITS_SZVALSTR] + +begin + call fxf_gstr (card, sval, FITS_SZVALSTR) + ip = 1 + if (ctoi (sval, ip, ival) <= 0) + ival = 0 +end + + +# FXF_GETR -- Return the real value of a FITS encoded card. + +procedure fxf_getr (card, rval) + +char card[ARB] # card to be decoded +real rval # receives integer value + +int ip, ctor() +char sval[FITS_SZVALSTR] + +begin + call fxf_gstr (card, sval, FITS_SZVALSTR) + ip = 1 + if (ctor (sval, ip, rval) <= 0) + rval = 0.0 +end + + +# FXF_GETD -- Return the double value of a FITS encoded card. + +procedure fxf_getd (card, dval) + +char card[ARB] # card to be decoded +double dval # receives integer value + +int ip, ctod() +char sval[FITS_SZVALSTR] + +begin + call fxf_gstr (card, sval, FITS_SZVALSTR) + ip = 1 + if (ctod (sval, ip, dval) <= 0) + dval = 0.0 +end + + +# FXF_GETB -- Return the boolean/integer value of a FITS encoded card. + +procedure fxf_getb (card, bval) + +char card[ARB] # card to be decoded +int bval # receives YES/NO + +char sval[FITS_SZVALSTR] + +begin + call fxf_gstr (card, sval, FITS_SZVALSTR) + if (sval[1] == 'T') + bval = YES + else + bval = NO +end + + +# FXF_GSTR -- Get the string value of a FITS encoded card. Strip leading +# and trailing whitespace and any quotes. + +procedure fxf_gstr (card, outstr, maxch) + +char card[ARB] # FITS card to be decoded +char outstr[ARB] # output string to receive parameter value +int maxch + +int ip, op +int ctowrd(), strlen() + +begin + ip = FITS_STARTVALUE + if (ctowrd (card, ip, outstr, maxch) > 0) { + # Strip trailing whitespace. + op = strlen (outstr) + while (op > 0 && (IS_WHITE(outstr[op]) || outstr[op] == '\n')) + op = op - 1 + outstr[op+1] = EOS + } else + outstr[1] = EOS +end + + +# FXF_GETCMT -- Get the comment field of a FITS encoded card. + +procedure fxf_getcmt (card, comment, maxch) + +char card[ARB] #I FITS card to be decoded +char comment[ARB] #O output string to receive comment +int maxch #I max chars out + +int ip, op +int lastch + +begin + # Find the slash which marks the beginning of the comment field. + ip = FITS_ENDVALUE + 1 + while (card[ip] != EOS && card[ip] != '\n' && card[ip] != '/') + ip = ip + 1 + + # Copy the comment to the output string, omitting the /, any + # trailing blanks, and the newline. + + lastch = 0 + do op = 1, maxch { + if (card[ip] == EOS) + break + ip = ip + 1 + comment[op] = card[ip] + if (card[ip] > ' ') + lastch = op + } + comment[lastch+1] = EOS +end + + +# FXF_GLTM -- Procedure to convert an input time stream with hh:mm:ss +# and date stream dd/mm/yy into seconds from jan 1st 1980. + +procedure fxf_gltm (time, date, limtime) + +char time[ARB], date[ARB] +int limtime + +int month_to_days[12], adays +int hr,mn,sec,days,month,year, ip, iy, days_per_year, ctoi(), i +data month_to_days / 0,31,59,90,120,151,181,212,243,273,304,334/ + +begin + + ip = 1; ip = ctoi (time, ip, hr) + ip = 1; ip = ctoi (time[4], ip, mn) + ip = 1; ip = ctoi (time[7], ip, sec) + + sec = sec + mn * 60 + hr * 3600 + + ip = 1; ip = ctoi (date, ip, days) + ip = 1; ip = ctoi (date[4], ip, month) + ip = 1; ip = ctoi (date[7], ip, year) + + days_per_year = 0 + iy = year + 1900 + do i = 1, iy - 1980 + days_per_year = days_per_year + 365 + + adays = (year - 80) / 4 + if (month > 2) + adays = adays + 1 + + days = adays + days-1 + days_per_year + month_to_days[month] + limtime = sec + days * 86400 +end diff --git a/sys/imio/iki/fxf/fxfhextn.x b/sys/imio/iki/fxf/fxfhextn.x new file mode 100644 index 00000000..7f8a879d --- /dev/null +++ b/sys/imio/iki/fxf/fxfhextn.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> +include "fxf.h" + + +# FXF_GETHDREXTN -- Get the default header file extension. + +procedure fxf_gethdrextn (im, o_im, acmode, outstr, maxch) + +pointer im, o_im #I image descriptors +int acmode #I image access mode +char outstr[ARB] #O receives header extension +int maxch #I max chars out + +bool inherit +int kernel, old_kernel +int fnextn(), iki_getextn(), iki_getpar() + +begin + # Use the same extension as the input file if this is a new copy + # image of the same type as the input and inherit is enabled. + # If we have to get the extension using iki_getextn, the default + # extension for a new image is the first extension defined (index=1). + + kernel = IM_KERNEL(im) + + old_kernel = 0 + if (acmode == NEW_COPY && o_im != NULL) + old_kernel = IM_KERNEL(o_im) + + inherit = (iki_getpar ("inherit") == YES) + if (inherit && acmode == NEW_COPY && kernel == old_kernel) { + if (fnextn (IM_HDRFILE(im), outstr, maxch) <= 0) + call strcpy (DEF_HDREXTN, outstr, maxch) + } else if (iki_getextn (kernel, 1, outstr, maxch) < 0) + call strcpy (DEF_HDREXTN, outstr, maxch) +end diff --git a/sys/imio/iki/fxf/fxfksection.x b/sys/imio/iki/fxf/fxfksection.x new file mode 100644 index 00000000..cb37b4e5 --- /dev/null +++ b/sys/imio/iki/fxf/fxfksection.x @@ -0,0 +1,475 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <error.h> +include <ctotok.h> +include <lexnum.h> +include <imhdr.h> +include "fxf.h" + +# FXFKSECTION.X -- Routines to parse the FITS kernel section into +# parameter names and values. + +define KS_EXTNAME 1 +define KS_EXTVER 2 +define KS_APPEND 3 +define KS_NOAPPEND 4 +define KS_OVERWRITE 5 +define KS_DUPNAME 6 +define KS_INHERIT 7 +define KS_NOINHERIT 8 +define KS_NODUPNAME 9 +define KS_NOOVERWRITE 10 +define KS_EXPAND 11 +define KS_PHULINES 12 +define KS_EHULINES 13 +define KS_PADLINES 14 +define KS_NOEXPAND 15 +define KS_CACHESIZE 16 +define KS_TYPE 17 +define ERROR -2 + + +# FXF_KSECTION -- Procedure to parse and analyze a string of the form: +# +# "keyword=value,keyword+,keyword-,..." +# e.g., +# "[extname=]name,[extver=]23,append,inherit+,overwrite+,dupname-" +# +# The 'extver' numeric field is position dependent if it does not have +# the parameter name. The 'group' output variable is not -1 when specified +# as the 1st number in the section. + +procedure fxf_ksection (ksection, fit, group) + +char ksection[ARB] #I String with kernel section +pointer fit #I Fits structure pointer +int group #O Extension number + +bool extn +char outstr[LEN_CARD] +char identif[LEN_CARD] +int ip, jp, nident, nexpr, junk, nch, ty, token, ival +int lex_type, fxf_ks_lex(), ctoi(), ctotok(), lexnum() +errchk syserr, syserrs + +begin + # The default values should have been already initialized + # with a call fxf_ksinit(). + + ip = 1 + nexpr = 0 + nident = 0 + extn = false + group = -1 + identif[1] = EOS + + repeat { + # Advance to the next keyword. + token = ctotok (ksection, ip, outstr, LEN_CARD) + + switch (token) { + case TOK_EOS: + break + case TOK_NEWLINE: + break + + case TOK_NUMBER: + if (nexpr != 1 && nexpr != 2 && extn) + call syserr (SYS_FXFKSNV) + jp = 1 + ty = lexnum (outstr, jp, nch) + if (ty != LEX_DECIMAL) + call syserr (SYS_FXFKSNDEC) + jp = 1 + junk = ctoi (outstr, jp, ival) + if (nexpr == 0) { + group = ival + identif[1] = 1 + } else + FKS_EXTVER(fit) = ival + nexpr = nexpr + 1 + + case TOK_PUNCTUATION: + if (outstr[1] == ',' && identif[1] == EOS) + call syserr (SYS_FXFKSSYN) + + case TOK_STRING: + if (nexpr != 0 && nexpr != 1) + call syserr (SYS_FXFKSSVAL) + call strcpy (outstr, FKS_EXTNAME(fit), LEN_CARD) + nexpr = nexpr + 1 + extn = true + + case TOK_IDENTIFIER: + nident = nident + 1 + call strcpy (outstr, identif, LEN_CARD] + call strlwr (outstr) + lex_type = fxf_ks_lex (outstr) + + # look for =<value>, + or - + if (lex_type > 0) { + call fxf_ks_gvalue (lex_type, ksection, ip, fit) + } else { + if (nexpr == 0 || nexpr == 1) + call strcpy (identif, FKS_EXTNAME(fit), LEN_CARD) + else + call syserr (SYS_FXFKSSVAL) + } + nexpr = nexpr + 1 + extn = true + + default: + call syserr (SYS_FXFKSSYN) + } + } +end + + +# FXF_KS_LEX -- Map an identifier into a FITS kernel parameter code. + +int procedure fxf_ks_lex (outstr) + +char outstr[ARB] + +int len, strlen(), strncmp() +errchk syserr, syserrs + +begin + len = strlen (outstr) + + # Allow for small string to be taken as extname values and not + # kernel paramaters; like 'ap' instead of 'ap(ppend)'. + if (len < 3) + return(0) + + # See if it is extname or extver. + if (strncmp (outstr, "ext", 3) == 0 && len < 8 ) { + if (len == 3) + call syserr (SYS_FXFKSEXT) + if (strncmp (outstr[4], "name", len-3) == 0) + return (KS_EXTNAME) + else if (strncmp (outstr[4], "ver", len-3) == 0) + return (KS_EXTVER) + + # Check for the "no" versions of selected keywords. + } else if (strncmp (outstr, "no", 2) == 0 && len < 12) { + if (strncmp (outstr[3], "append", len-2) == 0) + return (KS_NOAPPEND) + if (strncmp (outstr[3], "inherit", len-2) == 0) + return (KS_NOINHERIT) + if (strncmp (outstr[3], "overwrite", len-2) == 0) + return (KS_NOOVERWRITE) + if (strncmp (outstr[3], "dupname", len-2) == 0) + return (KS_NODUPNAME) + if (strncmp (outstr[3], "expand", len-2) == 0) + return (KS_NOEXPAND) + } + + # Other kernel keywords. + if (strncmp (outstr, "inherit", len) == 0) + return (KS_INHERIT) + if (strncmp (outstr, "overwrite", len) == 0) + return (KS_OVERWRITE) + if (strncmp (outstr, "dupname", len) == 0) + return (KS_DUPNAME) + if (strncmp (outstr, "append", len) == 0) + return (KS_APPEND) + if (strncmp (outstr, "noappend", len) == 0) + return (KS_NOAPPEND) + if (strncmp (outstr, "type", len) == 0) + return (KS_TYPE) + if (strncmp (outstr, "expand", len) == 0) + return (KS_EXPAND) + if (strncmp (outstr, "phulines", len) == 0) + return (KS_PHULINES) + if (strncmp (outstr, "ehulines", len) == 0) + return (KS_EHULINES) + if (strncmp (outstr, "padlines", len) == 0) + return (KS_PADLINES) + if (strncmp (outstr, "cachesize", len) == 0) + return (KS_CACHESIZE) + + return (0) # not recognized; probably a value +end + + +# FXF_KS_GVALUE -- Given a parameter code get its value at the 'ip' character +# position in the 'ksection' string. Put the values in the FKS structure. + +procedure fxf_ks_gvalue (param, ksection, ip, fit) + +int param #I parameter code +char ksection[ARB] #I Ksection +int ip #I Current parsing pointer in ksection +pointer fit #U Update the values in the FKS structure + +pointer sp, ln +int jp, token +int ctotok() +errchk syserr, syserrs + +begin + jp = ip + + call smark (sp) + call salloc (ln, LEN_CARD, TY_CHAR) + + # See if the parameter value is given as par=<value> or '+/-' + if (ctotok (ksection, jp, Memc[ln], LEN_CARD) == TOK_OPERATOR) { + if (Memc[ln] == '=' ) { + token = ctotok (ksection, jp, Memc[ln], LEN_CARD) + if (token != TOK_IDENTIFIER && + token != TOK_STRING && token != TOK_NUMBER) { + call syserr (SYS_FXFKSSYN) + } else { + call fxf_ks_val (Memc[ln], param, fit) + ip = jp + } + } else if (Memc[ln] == '+' || Memc[ln] == '-') { + call fxf_ks_pm (Memc[ln], param, fit) + ip = jp + } + } else { + switch (param) { + case KS_APPEND: + FKS_APPEND(fit) = YES + case KS_NOAPPEND: + FKS_APPEND(fit) = NO + case KS_OVERWRITE: + FKS_OVERWRITE(fit) = YES + case KS_NOOVERWRITE: + FKS_OVERWRITE(fit) = NO + case KS_DUPNAME: + FKS_DUPNAME(fit) = YES + case KS_INHERIT: + FKS_INHERIT(fit) = YES + case KS_NOINHERIT: + FKS_INHERIT(fit) = NO + case KS_EXPAND: + FKS_EXPAND(fit) = YES + case KS_NOEXPAND: + FKS_EXPAND(fit) = NO + default: + call syserr (SYS_FXFKSSYN) + } + } + + call sfree (sp) +end + + +# FXF_KS_VALUE -- Returns the value of a parameter in the kernel section. + +procedure fxf_ks_val (outstr, param, fit) + +char outstr[ARB] #I Input string with value +int param #I Parameter code +pointer fit #U Fits kernel descriptor + +int ty, ip, ival, nchars +int lexnum(), ctoi(), strcmp() +errchk syserr, syserrs + +begin + call strlwr (outstr) + if (strcmp (outstr, "yes") == 0) + ival = YES + else if (strcmp (outstr, "no") == 0) + ival = NO + else + ival = ERROR + + switch (param) { + case KS_EXTNAME: + call strcpy (outstr, FKS_EXTNAME(fit), LEN_CARD) + + case KS_TYPE: + call strlwr (outstr) + if (strcmp ("mask", outstr) == 0) + FKS_SUBTYPE(fit) = FK_PLIO + else + call syserrs (SYS_FXFKSINVAL, "type") + case KS_EXTVER: + ip = 1 + ty = lexnum (outstr, ip, nchars) + if (ty != LEX_DECIMAL) + call syserr (SYS_FXFKSNDEC) + ip = 1 + nchars = ctoi (outstr, ip, ival) + if (nchars <= 0) + call syserrs (SYS_FXFKSINVAL, "extver") + FKS_EXTVER(fit) = ival + + case KS_APPEND: + if (ival != ERROR) + FKS_APPEND(fit) = ival + else + call syserrs (SYS_FXFKSINVAL, "append") + + case KS_OVERWRITE: + if (ival != ERROR) + FKS_OVERWRITE(fit) = ival + else + call syserrs (SYS_FXFKSINVAL, "overwrite") + + case KS_DUPNAME: + if (ival != ERROR) + FKS_DUPNAME(fit) = ival + else + call syserrs (SYS_FXFKSINVAL, "dupname") + + case KS_INHERIT: + if (ival != ERROR) + FKS_INHERIT(fit) = ival + else + call syserrs (SYS_FXFKSINVAL, "inherit") + + case KS_EXPAND: + if (ival != ERROR) + FKS_EXPAND(fit) = ival + else + call syserrs (SYS_FXFKSINVAL, "expand") + + case KS_PHULINES: + ip = 1 + ty = lexnum (outstr, ip, nchars) + if (ty != LEX_DECIMAL) + call syserr (SYS_FXFKSNDEC) + ip = 1 + nchars = ctoi (outstr, ip, ival) + if (nchars <= 0 || ival < 0) + call syserrs (SYS_FXFKSPVAL, "phulines") + FKS_PHULINES(fit) = ival + + case KS_EHULINES: + ip = 1 + ty = lexnum (outstr, ip, nchars) + if (ty != LEX_DECIMAL) + call syserr (SYS_FXFKSNDEC) + ip = 1 + nchars = ctoi (outstr, ip, ival) + if (nchars <= 0 || ival < 0) + call syserrs (SYS_FXFKSPVAL, "ehulines") + FKS_EHULINES(fit) = ival + + case KS_PADLINES: + ip = 1 + ty = lexnum (outstr, ip, nchars) + if (ty != LEX_DECIMAL) + call syserr (SYS_FXFKSNDEC) + ip = 1 + nchars = ctoi (outstr, ip, ival) + if (nchars <= 0 || ival < 0) + call syserrs (SYS_FXFKSPVAL, "padlines") + FKS_PADLINES(fit) = ival + + case KS_CACHESIZE: + ip = 1 + ty = lexnum (outstr, ip, nchars) + if (ty != LEX_DECIMAL) + call syserr (SYS_FXFKSNDEC) + ip = 1 + nchars = ctoi (outstr, ip, ival) + if (nchars <= 0 || ival < 0) + call syserrs (SYS_FXFKSPVAL, "cachesize") + FKS_CACHESIZE(fit) = ival + + default: + call syserr (SYS_FXFKSSYN) + } +end + + +# FXF_KS_PM -- Return the character YES or NO based on the value '+' or '-' + +procedure fxf_ks_pm (pm, param, fit) + +char pm[1] #I contains "+" or "-" +int param #I Parameter code +pointer fit #U Fits kernel descriptor + +int ival +errchk syserr, syserrs + +begin + if (pm[1] == '+') + ival = YES + else + ival = NO + + switch (param) { + case KS_APPEND: + FKS_APPEND(fit) = ival + case KS_OVERWRITE: + FKS_OVERWRITE(fit) = ival + case KS_DUPNAME: + FKS_DUPNAME(fit) = ival + case KS_INHERIT: + FKS_INHERIT(fit) = ival + case KS_EXPAND: + FKS_EXPAND(fit) = ival + default: + call syserr (SYS_FXFKSSYN) + } +end + + +# FXF_KS_ERRORS -- Handle an error condition in the kernel section. + +procedure fxf_ks_errors (fit, acmode) + +pointer fit #I fits kernel descriptor +int acmode #I image access mode + +int group +errchk syserr, syserrs + +begin + group = FIT_GROUP(fit) + + if (FKS_OVERWRITE(fit) == YES) { + if (FIT_NEWIMAGE(fit) == YES) + iferr (call syserrs (SYS_FOPNNEXFIL, IM_HDRFILE(FIT_IM(fit)))) + call erract (EA_WARN) + if (acmode == APPEND) + call syserrs (SYS_FXFKSNOVR, "APPEND") + if (group == -1 && + (FKS_EXTNAME(fit) == EOS && IS_INDEFL(FKS_EXTVER(fit)))) + call syserr (SYS_FXFKSOVR) + } else { + switch (acmode) { + case NEW_COPY: + if (group != -1 && FKS_APPEND(fit) == NO) + call syserr (SYS_FXFKSBOP) + case NEW_IMAGE: + if (group != -1) + call syserrs (SYS_FXFKSNEXT, "NEW_IMAGE" ) + case APPEND: + if (group != -1) + call syserrs (SYS_FXFKSNEXT, "APPEND" ) + } + } +end + + +# FXF_KSINIT -- Initialize default values for ks parameters. + +procedure fxf_ksinit (fit) + +pointer fit #I fits kernel descriptor + +begin + FKS_EXTNAME(fit) = EOS + FKS_SUBTYPE(fit) = NO + FKS_EXTVER(fit) = INDEFL + FKS_APPEND(fit) = NO + FKS_OVERWRITE(fit) = NO + FKS_DUPNAME(fit) = NO + FKS_EXPAND(fit) = YES + FKS_PHULINES(fit) = DEF_PHULINES + FKS_EHULINES(fit) = DEF_EHULINES + FKS_PADLINES(fit) = DEF_PADLINES + FKS_INHERIT(fit) = YES + FKS_CACHESIZE(fit) = DEF_CACHE +end diff --git a/sys/imio/iki/fxf/fxfmkcard.x b/sys/imio/iki/fxf/fxfmkcard.x new file mode 100644 index 00000000..81bb3ab7 --- /dev/null +++ b/sys/imio/iki/fxf/fxfmkcard.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# FXF_MK_CARD -- Fetch a single line from a string parameter, padding it to +# a maximum of maxcols characters and trimmimg the delim character. + +procedure fxf_make_card (instr, ip, card, col_out, maxcols, delim) + +char instr[ARB] #I input string +int ip #U input string pointer, updated at each call +char card[ARB] #O FITS card image +int col_out #I pointer to column in card +int maxcols #I maximum columns in card +int delim #I 1 character string delimiter + +int op + +begin + op = col_out + + # Copy string + while (op <= maxcols && instr[ip] != EOS && instr[ip] != delim) { + card[op] = instr[ip] + ip = ip + 1 + op = op + 1 + } + + # Fill remainder of card with blanks + while (op <= maxcols ) { + card[op] = ' ' + op = op + 1 + } + + if (instr[ip] == delim) + ip = ip + 1 +end diff --git a/sys/imio/iki/fxf/fxfnull.x b/sys/imio/iki/fxf/fxfnull.x new file mode 100644 index 00000000..ce3baece --- /dev/null +++ b/sys/imio/iki/fxf/fxfnull.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include "fxf.h" + +# FXF_NULL -- Null driver entry point. + +procedure fxf_null() + +errchk syserr, syserrs + +begin + call syserr (SYS_FXFFKNULL) +end diff --git a/sys/imio/iki/fxf/fxfopen.x b/sys/imio/iki/fxf/fxfopen.x new file mode 100644 index 00000000..bceed618 --- /dev/null +++ b/sys/imio/iki/fxf/fxfopen.x @@ -0,0 +1,1014 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <error.h> +include <imhdr.h> +include <imio.h> +include <finfo.h> +include <fset.h> +include <mii.h> +include <mach.h> +include "fxf.h" + + +# FXF_OPEN -- Open/create a FITS format image with extensions. + +procedure fxf_open (kernel, im, o_im, root, extn, ksection, group, gc_arg, + acmode, status) + +int kernel #I IKI kernel +pointer im #I image descriptor +pointer o_im #I other descriptor for NEW_COPY image +char root[ARB] #I root image name +char extn[ARB] #I extension, if any +char ksection[ARB] #I [extname,extver,overwrite,append,inherit..] +int group #I index of group to be accessed +int gc_arg #I [NOT USED] +int acmode #I access mode +int status #O status flag to calling routine + +long fi[LEN_FINFO] +int newimage, i, gn, ksinh, type, fmode +pointer sp, path, fit_extn, ua, o_fit, fit +bool pre_read, fks_extn_or_ver, dyh, fsec, plio +int fxf_check_dup_extnv(), itoc(), strcmp(), strncmp() +int open(), access(), imgeti(), fstatl(), finfo(), fxf_header_size() +pointer pl_open() + +errchk fmkcopy, calloc, open, fxf_rheader, fxf_prhdr, fxf_gaccess +errchk fxf_fclobber, fxf_ksection, fxf_alloc, syserr, syserrs +errchk fxf_check_group +define duperr_ 91 +define err_ 92 + +begin + call smark (sp) + call salloc (path, SZ_PATHNAME, TY_CHAR) + call salloc (fit_extn, FITS_LENEXTN, TY_CHAR) + call fxf_init() + ua = IM_USERAREA(im) + + fmode = acmode + + # Allocate internal FITS image descriptor. + call fxf_alloc (fit) + + IM_KDES(im) = fit + IM_HFD(im) = NULL + FIT_IM(fit) = im + call amovki (1, FIT_LENAXIS(fit,1), IM_MAXDIM) + + # Generate full header file name. + if (extn[1] == EOS) { + call fxf_gethdrextn (im, o_im, fmode, Memc[fit_extn], FITS_LENEXTN) + call iki_mkfname (root, Memc[fit_extn], Memc[path], SZ_PATHNAME) + call strcpy (Memc[fit_extn], extn, FITS_LENEXTN) + } else + call iki_mkfname (root, extn, Memc[path], SZ_PATHNAME) + + # Header and pixel filename are the same. + call strcpy (Memc[path], IM_HDRFILE(im), SZ_IMHDRFILE) + call strcpy (IM_HDRFILE(im), IM_PIXFILE(im), SZ_IMPIXFILE) + + newimage = NO + if (access (IM_HDRFILE(im), 0, 0) == NO) + newimage = YES + FIT_NEWIMAGE(fit) = newimage + + # Initialize kernel section default values. + call fxf_ksinit (fit) + + # For simplicity treat the APPEND mode as NEW_IMAGE. For the FK + # is the same. + + if (fmode == APPEND) + fmode = NEW_IMAGE + FIT_ACMODE(fit) = fmode + + # Read fkinit and ksection and check that the extension number + # specifications therein and the IMIO cluster index "group" are + # consistent. + + call fxf_check_group (im, ksection, fmode, group, ksinh) + + fks_extn_or_ver = FKS_EXTNAME(fit) != EOS || !IS_INDEFL(FKS_EXTVER(fit)) + + # Check if a file section is necessary. + fsec = (fks_extn_or_ver || group >= 0) + call fxf_gaccess (im, fsec) + + # The previous call could have changed FIT_NEWIMAGE; reset value. + newimage = FIT_NEWIMAGE(fit) + + if (fks_extn_or_ver) + FIT_GROUP(fit) = -1 + + # See if we want to write a dummy primary unit. + # + # For PLIO, if creating a new output file and we want to create a + # BINTABLE, create a dummy header. Otherwise see if a type is + # requested, in which case we would need to create a dummmy header + # if no file is present yet. + + type = 0 + if (FKS_SUBTYPE(fit) == FK_PLIO) + type = FK_PLIO + + dyh = false + if (newimage == YES && (fks_extn_or_ver || type > 0)) { + call fxf_dummy_header (im, status) + if (status == ERR) + goto err_ + newimage = NO + dyh = true + if (fmode == NEW_COPY && type == FK_PLIO) + FIT_PIXOFF(fit) = fxf_header_size(im) + FITS_BLOCK_CHARS + } + if (newimage == NO) { + if (finfo (IM_HDRFILE(im), fi) != ERR) + FIT_EOFSIZE(fit) = (FI_SIZE(fi)+SZB_CHAR-1)/SZB_CHAR + 1 + else + call syserrs (SYS_FOPEN, IM_HDRFILE(im)) + } + + if (newimage == YES) + FKS_OVERWRITE(fit) = NO + else + FIT_XTENSION(fit) = YES + + FIT_NEWIMAGE(fit) = newimage + + # If all these conditions are met then set the pre_read flag. + pre_read = (fks_extn_or_ver || + FKS_OVERWRITE(fit) == YES || FKS_INHERIT(fit) == YES) + + if (newimage == NO && fmode != READ_ONLY) { + # See that INHERIT makes sense if it has been set by + # 'fkinit' when reading a file with PHU (naxis != 0). + + if (FKS_INHERIT(fit) == YES && group != 0) { + gn = 0 + iferr (call fxf_prhdr (im, gn)) { + FKS_INHERIT(fit) = NO + + # Issue an error only if the inherit is in the filename. + if (fmode == NEW_COPY && ksinh == YES) + call syserr (SYS_FXFBADINH) + } else if (FIT_NAXIS(fit) != 0) + FKS_INHERIT(fit) = NO + + # Reset the pre_read flag. + pre_read = ((FKS_DUPNAME(fit) == NO && + FKS_INHERIT(fit) == YES) || FKS_OVERWRITE(fit) == YES) + } + + if (pre_read && fmode != NEW_COPY && !dyh) + call fxf_prhdr (im, group) + + if (access (IM_HDRFILE(im), fmode, 0) == NO) + call syserrs (SYS_FNOWRITEPERM, IM_HDRFILE(im)) + } + + switch (fmode) { + case NEW_IMAGE, APPEND: + if (newimage == NO) { + # Make sure the UA is empty when overwriting. + if (pre_read && FKS_OVERWRITE(fit) == YES) + Memc[ua] = EOS + + if (FKS_DUPNAME(fit) == NO) + if (fxf_check_dup_extnv (im, group) == YES) + goto duperr_ + } else { + # See if it is necessary to invalidate the cache entry for the + # current filename. It could happen that the user has deleted + # the filename and a new file with the same is created. + + call fxf_check_old_name (im) + } + + if (FKS_INHERIT(fit) == YES) + FIT_INHERIT(fit) = YES + + # Initialize a new copy of a PLIO image mask. + if (type == FK_PLIO) + IM_PL(im) = pl_open (NULL) + + case NEW_COPY: + # Completely new copy of an existing image. This could mean a + # new file or append a new image to an existing file. + + # Initialize a new copy of a PLIO image mask. + if (type == FK_PLIO) { + IM_PL(im) = pl_open (NULL) + if (IM_PL(o_im) != NULL) + call fxf_plpf (im) + } + + if (newimage == YES || FKS_APPEND(fit) == NO) + call fxf_check_old_name (im) + + # For a PLIO mask, make sure there are no SUBYTPE keywords in + # the UA since this will be rewritten by fxf_updhdr(). + + if (IM_PL(o_im) != NULL) + call fxf_clean_pl (im) + + if (IM_KDES(o_im) != NULL && IM_KERNEL(o_im) == IM_KERNEL(im)) { + o_fit = IM_KDES(o_im) + call strcpy (FIT_EXTTYPE(o_fit), FIT_EXTTYPE(fit), SZ_EXTTYPE) + call strcpy (FIT_EXTNAME(o_fit), FIT_EXTNAME(fit), LEN_CARD) + FIT_EXTVER(fit) = FIT_EXTVER(o_fit) + + # Reset the value of the keyword INHERIT in the new_copy + # image if the input has a no_inherit in the filename. + + FIT_INHERIT(fit) = NO + call fxf_filter_keyw (im, "INHERIT") + + # Change the value only if explicitly done in the output + # kernel section. + + if (FKS_INHERIT(fit) == YES) + FIT_INHERIT(fit) = YES + + } else { + # Reblock if old image is imh for example. + if (IM_UABLOCKED(im) != YES) + call fxf_reblock (im) + + # See if the old image have EXTNAME or EXTVER keywords. + # Notice that old image does not have to be of FITS type. + + iferr (call imgstr (o_im,"EXTNAME",FIT_EXTNAME(fit),LEN_CARD)) + FIT_EXTNAME(fit) = EOS + iferr (FIT_EXTVER(fit) = imgeti (o_im, "EXTVER")) + FIT_EXTVER(fit) = INDEFL + call strcpy ("IMAGE", FIT_EXTTYPE(fit), SZ_EXTTYPE) + } + + # Delete ORIGIN keyword, since we are going to put a new one. + call fxf_filter_keyw (im, "ORIGIN") + + # Now that we have a new_copy of the input FITS structure, + # initialize some of its members. + + FIT_HFD(fit) = NULL + FIT_NEWIMAGE(fit) = newimage + if (newimage == NO) + FIT_XTENSION(fit) = YES + FIT_ACMODE(fit) = fmode + if (FKS_APPEND(fit) != YES) + FIT_GROUP(fit) = group + FIT_BSCALE(fit) = 1.0d0 + FIT_BZERO(fit) = 0.0d0 + + if (FKS_OVERWRITE(fit) == NO) { + if (FKS_EXTNAME(fit) == EOS) + call strcpy (FIT_EXTNAME(fit), FKS_EXTNAME(fit), LEN_CARD) + else + call imastr (im, "EXTNAME", FKS_EXTNAME(fit)) + + if (IS_INDEFL(FKS_EXTVER(fit))) + FKS_EXTVER(fit) = FIT_EXTVER(fit) + else + call imaddi (im, "EXTVER", FKS_EXTVER(fit)) + + # We need to pre_read extensions headers to check for + # duplicates with these extname and extver. + + if (FKS_EXTNAME(fit) != EOS ||!IS_INDEFL(FKS_EXTVER(fit))) + pre_read = true + } + + if (newimage == NO && !dyh) { + if (pre_read) { + iferr (call fxf_prhdr (im, group)) + ; + } + + # Check for duplicated EXTNAME and/or EXTVER if any of the + # following conditions are met. + + if (FKS_DUPNAME(fit) == NO && FKS_OVERWRITE(fit) == NO && + (fks_extn_or_ver || FIT_EXTNAME(fit) != EOS || + !IS_INDEFL(FIT_EXTVER(fit)))) { + if (fxf_check_dup_extnv (im, group) == YES) + goto duperr_ + } + } + + FIT_NAXIS(fit) = IM_NDIM(im) + do i = 1, IM_NDIM(im) + FIT_LENAXIS(fit,i) = IM_LEN(im,i) + + # Inherit datatype of input template image if specified, + # otherwise default datatype to real. + + if (IM_PIXTYPE(o_im) != NULL) + IM_PIXTYPE(im) = IM_PIXTYPE(o_im) + else + IM_PIXTYPE(im) = TY_REAL + + default: + # No Overwrite allowed in READ_ONLY or READ_WRITE. + FKS_OVERWRITE(fit) = NO + + # Check that we have single FITS file. + if (!fsec && group == -1) + group = 0 + + # Open an existing image. + iferr (call fpathname (IM_HDRFILE(im), Memc[path], SZ_PATHNAME)) + goto err_ + if (fmode == READ_WRITE) + IM_HFD(im) = open (Memc[path], READ_WRITE, BINARY_FILE) + else + IM_HFD(im) = open (Memc[path], READ_ONLY, BINARY_FILE) + + iferr (call fxf_rheader (im, group, fmode)) { + call close (IM_HFD(im)) + call mfree (fit, TY_STRUCT) + call sfree (sp) + status = ERR + call erract (EA_ERROR) + } + + if (group == 0) + FIT_XTENSION(fit) = NO + else + FIT_XTENSION(fit) = YES + + # Some non-iraf fits files might have keywords that are + # imcompatible with our header. For example if hediting the header, + # make sure that they are eliminated. + + if (fmode == READ_WRITE) + call fxf_discard_keyw (im) + + FIT_EOFSIZE(fit) = fstatl (IM_HFD(im), F_FILESIZE) + 1 + + # PLIO. If we read the header of a PLIO_1 compressed image file + # then it is a PL file; now read the data. + + plio = (strncmp (FIT_EXTSTYPE(fit), "PLIO_1", 6) == 0) + if (plio) { + call fxf_plread (im) + + # We need to setup the IMIO descriptor if we need to write + # over a section; in particular IM_PFD needs to be defined. + + if (fmode == READ_WRITE) + call fxf_plpf (im) + } + + # Close the header file. + call close (IM_HFD(im)) + IM_HFD(im) = NULL + + # Do not allow the user to see any non_IMAGE extensions. + if (strcmp ("IMAGE", FIT_EXTTYPE(fit)) != 0 && + strcmp ("SIMPLE", FIT_EXTTYPE(fit)) != 0 && !plio) + call syserrs (SYS_IKIEXTN, IM_NAME(im)) + } + + FIT_HFD(fit) = IM_HFD(im) + status = OK + + call sfree (sp) + return +duperr_ + i = itoc (group, Memc[path], LEN_CARD) + call syserrs (SYS_FXFOPEXTNV, Memc[path]) +err_ + status = ERR + call mfree (fit, TY_STRUCT) + call sfree (sp) +end + + +# FXF_ALLOC -- Initialize memory for the FIT descriptor. + +procedure fxf_alloc (fit) + +pointer fit #I input fits descriptor + +errchk calloc + +begin + call calloc (fit, LEN_FITDES, TY_STRUCT) + + FIT_GROUP(fit) = -1 + FIT_PIXTYPE(fit) = NULL + FIT_BSCALE(fit) = 1.0d0 + FIT_BZERO(fit) = 0.0d0 + FIT_XTENSION(fit) = NO + FIT_INHERIT(fit) = NO + FIT_EOFSIZE(fit) = 0 + FIT_EXTNAME(fit) = EOS + FIT_EXTVER(fit) = INDEFL +end + + +# FXF_INIT -- Initialize any runtime FITS kernel descriptors to their +# process startup state. + +procedure fxf_init() + +int i +bool first_time +data first_time /true/ + +include "fxfcache.com" + +begin + # Disable the hdrcache until it is fully initialized in rfitshdr. + if (first_time) { + rf_cachesize = 0 + do i = 1, MAX_CACHE { + rf_fit[i] = 0 + } + + first_time = false + } +end + + +# FXF_KS_RDHDR -- Procedure to preread the FITS headers up to group +# 'group'. The idea is to have the offset pointers in memory since the +# can be overwritten or when no group (i.e. -1) is given and the extname or +# extver are specified. + +procedure fxf_prhdr (im, group) + +pointer im #I image descriptor +int group #I maximum group number to read + +int poff, extv +pointer fit, lim, lfit, sp, path +errchk fpathname, open, syserr, fxf_alloc, calloc +int open(), imgeti() + +begin + call smark (sp) + call salloc (path, SZ_PATHNAME, TY_CHAR) + + # We will use a local temporary imio and fit structures. +# call calloc (lim, LEN_IMDES+LEN_IMHDR+MIN_LENUSERAREA, TY_STRUCT) + call calloc (lim, LEN_IMDES+IM_LENHDRMEM(im), TY_STRUCT) + + call fxf_alloc (lfit) + + IM_KDES(lim) = lfit + fit = IM_KDES(im) + + FIT_GROUP(lfit) = group + FIT_ACMODE(lfit) = FIT_ACMODE(fit) + call strcpy (FKS_EXTNAME(fit), FKS_EXTNAME(lfit), LEN_CARD) + FKS_EXTVER(lfit) = FKS_EXTVER(fit) + + iferr (extv = imgeti (im, "EXTVER")) + extv = INDEFL + + FKS_OVERWRITE(lfit) = FKS_OVERWRITE(fit) + FKS_DUPNAME(lfit) = FKS_DUPNAME(fit) + FKS_INHERIT(lfit) = FKS_INHERIT(fit) + FKS_CACHESIZE(lfit) = FKS_CACHESIZE(fit) + + # Open an existing image. + call strcpy (IM_HDRFILE(im), IM_HDRFILE(lim), SZ_PATHNAME) + call strcpy (IM_NAME(im), IM_NAME(lim), SZ_PATHNAME) + + call fpathname (IM_HDRFILE(im), Memc[path], SZ_PATHNAME) + IM_HFD(lim) = open (Memc[path], READ_ONLY, BINARY_FILE) + + IM_LENHDRMEM(lim) = IM_LENHDRMEM(im) + + # If we want to inherit the global header we need to read + # the group specified in the filename. + + iferr (call fxf_rfitshdr (lim, group, poff)) { + call close (IM_HFD(lim)) + call mfree (lfit, TY_STRUCT) + call mfree (lim, TY_STRUCT) + call sfree (sp) + call erract (EA_ERROR) + + } else { + call close (IM_HFD(lim)) + call sfree (sp) + if (FKS_OVERWRITE(fit) == YES) + FIT_GROUP(fit) = FIT_GROUP(lfit) + group = FIT_GROUP(lfit) + + # Now set the offset pointers to the original 'fit' struct. + FIT_HDRPTR(fit) = FIT_HDRPTR(lfit) + FIT_PIXPTR(fit) = FIT_PIXPTR(lfit) + FIT_EXTEND(fit) = FIT_EXTEND(lfit) + + FIT_CACHEHDR(fit) = FIT_CACHEHDR(lfit) + FIT_CACHEHLEN(fit) = FIT_CACHEHLEN(lfit) + + FIT_NAXIS(fit) = FIT_NAXIS(lfit) + FIT_INHERIT(fit) = FIT_INHERIT(lfit) + FIT_PLMAXLEN(fit) = FIT_PLMAXLEN(lfit) + + IM_CTIME(im) = IM_CTIME(lim) + + call mfree (lfit, TY_STRUCT) + call mfree (lim, TY_STRUCT) + + if (extv != INDEFL) + call imaddi (im, "EXTVER", extv) + } +end + + +# FXF_DUMMY_HEADER -- Built a minimum Primary Fits header. This is +# necessary in case we are creating an IMAGE extension and we don't +# want to put any information in the PHU. + +procedure fxf_dummy_header (im, status) + +pointer im #I image descriptor +int status #O status flag + +char blank[1] +pointer sp, path, spp, mii, pn, n +int iso_cutover, fd, nblanks, size_rec + +int strlen(), open(), envgeti() +long clktime() + +begin + call smark (sp) + call salloc (spp, FITS_BLOCK_BYTES, TY_CHAR) + call salloc (mii, FITS_BLOCK_CHARS, TY_INT) + call salloc (path, SZ_PATHNAME, TY_CHAR) + + status = OK + + iferr { + call fpathname (IM_HDRFILE(IM), Memc[path], SZ_PATHNAME) + fd = open (Memc[path], NEW_FILE, BINARY_FILE) + } then { + call sfree (sp) + status = ERR + return + } + + pn = spp + call fxf_akwb ("SIMPLE", YES, "FITS STANDARD", pn) + call fxf_akwi ("BITPIX", 8, "Character information", pn) + call fxf_akwi ("NAXIS", 0, "No image data array present", pn) + call fxf_akwb ("EXTEND", YES, "File may contain extensions", pn) + call fxf_akwc ("ORIGIN", FITS_ORIGIN, + strlen(FITS_ORIGIN), "FITS file originator", pn) + + # Dates after iso_cutover use ISO format dates. + iferr (iso_cutover = envgeti (ENV_ISOCUTOVER)) + iso_cutover = DEF_ISOCUTOVER + + # Encode the DATE keyword. + call fxf_encode_date (clktime(long(0)), Memc[path], LEN_CARD, + "ISO", 2000) + call fxf_akwc ("DATE", Memc[path], + strlen(Memc[path]), "Date FITS file was generated", pn) + + blank[1] = ' ' + call amovkc (blank[1], Memc[pn], LEN_CARD) + call amovc ("END", Memc[pn], 3) + pn = pn + LEN_CARD + + n = pn - spp + size_rec = FITS_BLOCK_CHARS + nblanks = FITS_BLOCK_BYTES - n + call amovkc (blank[1], Memc[spp+n], nblanks) + call miipak (Memc[spp], Memi[mii], size_rec*2, TY_CHAR, MII_BYTE) + call write (fd, Memi[mii], size_rec) + + call close (fd) + + call sfree (sp) +end + + +# FXF_CHECK_DUP_EXTN_VER --- Function to check for a duplicate EXTNAME or +# EXTVER in the FITS file open with NEW_COPY mode. The filename specification +# does not have EXTNAME nor EXTVER in the ksection. +# Returns YES if there are duplicates. + +int procedure fxf_check_dup_extnv (im, group) + +pointer im #I image descriptor +int group #O extension number where there is a duplicate + +int cindx +pointer extn, extv, sp, hdrfile, fit, poff +int fxf_extnv_error() +bool streq() + +include "fxfcache.com" + +begin + call smark (sp) + call salloc (hdrfile, SZ_PATHNAME, TY_CHAR) + + call fpathname (IM_HDRFILE(im), Memc[hdrfile], SZ_PATHNAME) + fit = IM_KDES(im) + + do cindx=1, rf_cachesize { + if (rf_fit[cindx] == NULL) + next + + if (streq (Memc[hdrfile], rf_fname[1,cindx])) { + extn = rf_pextn[cindx] + extv = rf_pextv[cindx] + poff = rf_pixp[cindx] # pixel offset -1 if EOF + group = 1 + + # Now compare the input image FIT_EXT(NAME,VER) with + # the cache values of the NEW_COPY images. + + while (Memc[extn+LEN_CARD*group] != EOS || + !IS_INDEFL(Memi[extv+group]) || Memi[poff+group] != -1) { + if (fxf_extnv_error (fit, group, extn, extv) == YES) { + call sfree (sp) + if (FKS_OVERWRITE(fit) == YES) + return (NO) + else + return (YES) + } else + group = group + 1 + } + } + } + + call sfree (sp) + return (NO) +end + + +# FXF_CHECK_OLD_NAME -- Check is the filename is already in cache for a +# NEWIMAGE == YES mode; if so, make the entry obsolete. + +procedure fxf_check_old_name (im) + +pointer im #I image descriptor + +int cindx +pointer sp, hdrfile, fit +bool streq() + +include "fxfcache.com" + +begin + call smark (sp) + call salloc (hdrfile, SZ_PATHNAME, TY_CHAR) + + call fpathname (IM_HDRFILE(im), Memc[hdrfile], SZ_PATHNAME) + + fit = IM_KDES(im) + do cindx=1, rf_cachesize { + if (rf_fit[cindx] == NULL) + next + + # Verify that we have the correct file. + if (streq (Memc[hdrfile], rf_fname[1,cindx])) { + call mfree (rf_pextv[cindx], TY_INT) + call mfree (rf_pextn[cindx], TY_CHAR) + call mfree (rf_pixp[cindx], TY_INT) + call mfree (rf_hdrp[cindx], TY_INT) + call mfree (rf_fit[cindx], TY_STRUCT) + call mfree (rf_hdr[cindx], TY_CHAR) + rf_fit[cindx] = NULL + rf_mtime[cindx] = 0 # invalidate cache entry + rf_fname[1,cindx] = EOS + break + } + } + + call sfree (sp) +end + + +# FXF_REBLOCK -- If the user area is not blocked to fixed length records, e.g., +# as is possible in a new copy image, reblock it fixed length. + +procedure fxf_reblock (im) + +pointer im #I image descriptor + +pointer sp, lbuf, op, ua +int fd, spool, nlines, nchars, sz_userarea, len_hdrmem +errchk stropen, open, getline, putline, realloc, seek, fcopyo +int open(), stropen(), getline() + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + ua = IM_USERAREA(im) + fd = stropen (Memc[ua], ARB, READ_ONLY) + spool = open ("rb_spool", READ_WRITE, SPOOL_FILE) + + # Reblock into a spool file, counting the lines. + for (nlines=0; ; nlines=nlines+1) { + nchars = getline (fd, Memc[lbuf]) + if (nchars <= 0) + break + + for (op=nchars; op <= LEN_CARD; op=op+1) + Memc[lbuf+op-1] = ' ' + Memc[lbuf+LEN_CARD] = '\n' + Memc[lbuf+LEN_CARD+1] = EOS + call putline (spool, Memc[lbuf]) + } + + call close (fd) + + # Reallocate header the right size. + sz_userarea = nlines * (LEN_CARD+1) + SZ_EXTRASPACE + + IM_HDRLEN(im) = LEN_IMHDR + + (sz_userarea - SZ_EXTRASPACE + SZ_MII_INT-1) / SZ_MII_INT + len_hdrmem = LEN_IMHDR + + (sz_userarea+1 + SZ_MII_INT-1) / SZ_MII_INT + + if (IM_LENHDRMEM(im) < len_hdrmem) { + IM_LENHDRMEM(im) = len_hdrmem + call realloc (im, IM_LENHDRMEM(im) + LEN_IMDES, TY_STRUCT) + } + + # Move spooled data back to user area. + ua = IM_USERAREA(im) + fd = stropen (Memc[ua], sz_userarea, NEW_FILE) + call seek (spool, BOFL) + call fcopyo (spool, fd) + + IM_UABLOCKED(im) = YES + call close (fd) + call close (spool) + call sfree (sp) +end + + +# FXF_FCLOBBER -- Clobber an existing FITS file. We use the environment +# variable 'clobber' rather than 'imclobber' because is a file and not +# an image. + +procedure fxf_fclobber (file) + +char file #I input filename to delete + +int cindx +bool streq() +include "fxfcache.com" + +begin + iferr (call delete (file)) + call filerr (file, SYS_FCANTCLOB) + + # Remove the name from the cache. + do cindx=1, rf_cachesize { + if (rf_fit[cindx] == NULL) + next + + # Verify that we have the correct file. + if (streq (file, rf_fname[1,cindx])) { + if (rf_fit[cindx] != NULL) { + call mfree (rf_pextv[cindx], TY_INT) + call mfree (rf_pextn[cindx], TY_CHAR) + call mfree (rf_pixp[cindx], TY_INT) + call mfree (rf_hdrp[cindx], TY_INT) + call mfree (rf_fit[cindx], TY_STRUCT) + call mfree (rf_hdr[cindx], TY_CHAR) + rf_fit[cindx] = NULL + } + } + } +end + + +# FXF_ACCESS -- Check if a file section is necessary to access any +# particular extension. + +procedure fxf_gaccess (im, fsec) + +pointer im #I image descriptor +bool fsec #I true if extname,extver or group have values + +bool mef +int acmode, fit, newimage, group +bool envgetb(), fnullfile() +errchk syserr, syserrs, fxf_fclobber + +begin + fit = IM_KDES(im) + acmode = FIT_ACMODE(fit) + newimage = FIT_NEWIMAGE(fit) + + if (acmode == READ_ONLY || acmode == READ_WRITE) { + # If no file section then see if it is a MEF by prereading an + # extension. + + if (!fsec) { + group = 1 + mef = false + ifnoerr (call fxf_prhdr (im, group)) + mef = true + else { + # Flag error if the group does not exist and overwrite+. + if (FKS_OVERWRITE(fit) == YES) + call syserrs (SYS_FXFEXTNF, IM_NAME(im)) + } + # Multi-extension file but no extension was specified. + if (mef) + call syserrs (SYS_FXFOPNOEXTNV, IM_NAME(im)) + FIT_GROUP(fit) = 0 + FIT_XTENSION(fit) = NO + } + } + + switch (acmode) { + case NEW_COPY, NEW_IMAGE, APPEND: + if (envgetb ("imclobber")) { + if (newimage == NO) { + if (FKS_APPEND(fit) != YES && FKS_OVERWRITE(fit) != YES) { + # Clobber the file. + call fxf_fclobber (IM_HDRFILE(im)) + FIT_NEWIMAGE(fit) = YES + } + } + } else { + if (newimage == NO) + if (FKS_APPEND(fit) != YES && FKS_OVERWRITE(fit) != YES) { + if (!fnullfile (IM_HDRFILE(im))) + call syserrs (SYS_IKICLOB, IM_HDRFILE(im)) + } + } + default: + ; + } + +end + + +# FXF_CHECK_GROUP -- Check for group specification from fkinit, ksection +# and cluster index are equal when specifified and they are also compatible +# when (extname,extver) is in the kernel sections. + +procedure fxf_check_group (im, ksection, acmode, group, ksinh) + +pointer im #I imio descriptor +char ksection[ARB] #I kernel section +int acmode #I fits unit extension mode +int group #U extension number in the image section +int ksinh #O INHERIT value from the filename ksection + +pointer sp, ks, fit +bool fks_extn_or_ver, inherit_override +int igroup, kgroup, fgroup, tgroup, sv_inherit, newimage, append +bool fnullfile() +int envgets() + +errchk syserrs, fxf_ks_error + +begin + call smark (sp) + call salloc (ks, SZ_LINE, TY_CHAR) + + fit = IM_KDES(im) + newimage = FIT_NEWIMAGE(fit) + + # Set the FKINIT defaults; these override the builtin defaults. + fgroup = -1 + igroup = -1 + + FKS_APPEND(fit) = NO_KEYW + if (envgets (ENV_FKINIT, Memc[ks], SZ_LINE) != 0) + call fxf_ksection (Memc[ks], fit, igroup) + + append = FKS_APPEND(fit) + + sv_inherit = FKS_INHERIT(fit) + FKS_INHERIT(fit) = NO_KEYW + FKS_APPEND(fit) = NO_KEYW + + # Parse the kernel section. + call fxf_ksection (ksection, fit, kgroup) + ksinh = FKS_INHERIT(fit) + + # Check for various error conditions. + if (FKS_OVERWRITE(fit) == YES && FKS_APPEND(fit) == YES) + call syserrs (SYS_FXFKSNOVR, "append") + + if (append == NO_KEYW && FKS_APPEND(fit) == NO_KEYW) + FKS_APPEND(fit) = NO + else if (append != NO_KEYW) + FKS_APPEND(fit) = append + + if (append == YES && FKS_OVERWRITE(fit) == YES) + FKS_APPEND(fit) = NO + + if (group != -1) { + if (kgroup != -1 && group != kgroup) + call syserrs (SYS_FXFKSBADGR, IM_NAME(im)) + else if (igroup != -1 && group != igroup) + call syserrs (SYS_FXFKSBADFKIG, IM_NAME(im)) + fgroup = group + } else if (kgroup != -1) { + if (group != -1 && group != kgroup) + call syserrs (SYS_FXFKSBADGR, IM_NAME(im)) + else if (igroup != -1 && group != igroup) + call syserrs (SYS_FXFKSBADFKIG, IM_NAME(im)) + fgroup = kgroup + } else if (igroup != -1) { + if ((group != -1 && group != igroup) || + (kgroup != -1 && kgroup != igroup)) + call syserrs (SYS_FXFKSBADFKIG, IM_NAME(im)) + fgroup = igroup + } + group = fgroup + + # Pre-read the data header. This is done after processing the user + # ksection as we need to get the extname/extver if any. + # EXTNAME or EXTVER has priority when defined over group. + + fks_extn_or_ver = + (FKS_EXTNAME(fit) != EOS || !IS_INDEFL(FKS_EXTVER(fit))) + + tgroup = fgroup + if (fks_extn_or_ver) + tgroup = -1 + + if (newimage == NO && !fnullfile (IM_HDRFILE(im))) { + iferr (call fxf_prhdr (im, tgroup)) { + # If group does not exist and over+, it is an error. + if (FKS_OVERWRITE(fit) == YES) + call syserrs (SYS_FXFEXTNF, IM_NAME(im)) + else + call erract (EA_ERROR) + } + } + + if (fgroup != -1 && tgroup != fgroup && fks_extn_or_ver) + call syserrs (SYS_FXFKSBADEXN, IM_NAME(im)) + + if (fgroup == -1 && fks_extn_or_ver) + group = tgroup + + FIT_EXPAND(fit) = FKS_EXPAND(fit) + + # For overwrite we need to force group to be the kernel section + # extension number. + + if (FKS_OVERWRITE(fit) == YES) + FIT_GROUP(fit) = max(kgroup,group) + else + FIT_GROUP(fit) = group + + if (FKS_APPEND(fit) == YES) + FIT_GROUP(fit) = -1 + + # See if there are some error conditions with the ksection. + call fxf_ks_errors (fit, acmode) + + # Check to see if the user ksection sets the inherit flag. If so + # this overrides all the defaults, including the data header. + + inherit_override = (FKS_INHERIT(fit) != NO_KEYW) + if (!inherit_override) + FKS_INHERIT(fit) = sv_inherit + + # A data header has precedence over the more global fkinit. + # If inherit is disabled in the data header don't enable it here. + + if (!inherit_override && FIT_INHERIT(fit) == NO) + FKS_INHERIT(fit) = NO + + call sfree (sp) +end + + +# FXF_CLEAN_PL -- Filter PLIO keywords from the UA. + +procedure fxf_clean_pl (im) + +pointer im #I image descriptor + +begin + #### (This is incredibly inefficient...) + call fxf_filter_keyw (im, "TFORM1") + call fxf_filter_keyw (im, "TFIELDS") + call fxf_filter_keyw (im, "ZIMAGE") + call fxf_filter_keyw (im, "ZCMPTYPE") + call fxf_filter_keyw (im, "ZBITPIX") + call fxf_filter_keyw (im, "ZNAXIS") + call fxf_filter_keyw (im, "ZNAXIS1") + call fxf_filter_keyw (im, "ZNAXIS2") + call fxf_filter_keyw (im, "ZTILE1") + call fxf_filter_keyw (im, "ZTILE2") + call fxf_filter_keyw (im, "ZNAME1") + call fxf_filter_keyw (im, "ZVAL1") +end diff --git a/sys/imio/iki/fxf/fxfopix.x b/sys/imio/iki/fxf/fxfopix.x new file mode 100644 index 00000000..0401601b --- /dev/null +++ b/sys/imio/iki/fxf/fxfopix.x @@ -0,0 +1,746 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <error.h> +include <imhdr.h> +include <imio.h> +include <mach.h> +include "fxf.h" +include <fset.h> + +define MIN_BUFSIZE 512 + + +# FXF_OPIX -- Open (or create) the pixel storage file. + +procedure fxf_opix (im, status) + +pointer im #I image descriptor +int status #O return status + +pointer sp, fn, fit +char pathname[SZ_PATHNAME] +int compress, blklen, pixoff, filesize +int i, hdr_size, sz_pixfile, sz_fitfile, junk, npix +extern fxfzop(), fxfzrd(), fxfzwr(), fxfzwt(), fxfzst(), fxfzcl() +int strncmp(), fxf_header_size(), fxf_totpix() +int strlen(), fopnbf(), fstatl(), itoc() + +include <szpixtype.inc> + +define err_ 91 +define endowr_ 92 + +begin + call smark (sp) + call salloc (fn, SZ_PATHNAME, TY_CHAR) + + status = OK + fit = IM_KDES(im) + + compress = YES + blklen = 1 + pixoff = 1 + + # Tell IMIO where the pixels are. Append the 'fit' mem descriptor + # to filename so that low level zfiofit routines can use it. + + call strcpy (IM_HDRFILE(im), Memc[fn], SZ_PATHNAME) + call strcat ("_", Memc[fn], SZ_PATHNAME) + i = strlen (Memc[fn]) + junk = itoc (fit, Memc[fn+i], SZ_PATHNAME) + iferr (call fpathname (Memc[fn], pathname, SZ_PATHNAME)) + goto err_ + + if (FKS_OVERWRITE(fit) == YES) { + call fxf_overwrite_unit (fit, im) + goto endowr_ + } + + switch (IM_ACMODE(im)) { + case READ_ONLY, READ_WRITE, WRITE_ONLY: + # Turn on IEEE mapping on input only. + call ieegnanr (FIT_SVNANR(fit)) + call ieegmapr (FIT_SVMAPRIN(fit), FIT_SVMAPROUT(fit)) + call ieegnand (FIT_SVNAND(fit)) + call ieegmapd (FIT_SVMAPDIN(fit), FIT_SVMAPDOUT(fit)) + call ieesnanr (0.0) + call ieemapr (YES, NO) + call ieesnand (0.0D0) + call ieemapd (YES, NO) + + # If the FIT datatype is BYTE or SHORT with scaling then + # convert to TY_SHORT and TY_REAL respectively before + # releasing the data to the upper level calls. This is + # because IMIO does not support BYTE datatype and the need + # to scale 16 bits to 32 bits. + + # Do not open pixel portion if it is empty or is not + # an IMAGE type. + + if ((strncmp (FIT_EXTTYPE(fit), "IMAGE", 5) != 0 && + strncmp (FIT_EXTTYPE(fit), "SIMPLE", 6) != 0) || + IM_NDIM(im) <= 0) { + + goto err_ + } + + FIT_IM(fit) = im + iferr (IM_PFD(im) = fopnbf (pathname, IM_ACMODE(im), + fxfzop, fxfzrd, fxfzwr, fxfzwt, fxfzst, fxfzcl)) { + IM_PFD(im) = NULL + goto err_ + } + + FIT_TOTPIX(fit) = fxf_totpix(im) + filesize = fstatl (IM_PFD(im), F_FILESIZE) + FIT_PFD(fit) = IM_PFD(im) + + case NEW_COPY, NEW_IMAGE, APPEND: + # See if the application has set the number of dimensions. + call fxf_chk_ndim (im) + FIT_PIXTYPE(fit) = IM_PIXTYPE(im) + npix = fxf_totpix (im) + FIT_NAXIS(fit) = IM_NDIM(im) + call amovi (IM_LEN(im,1), FIT_LENAXIS(fit,1), IM_NDIM(im)) + + call fxf_discard_keyw (im) + FIT_TOTPIX(fit) = npix + + # Do not allow BSCALE and BZERO in the UA when making a new copy or + # new image if bitpix is negative. Except for ushort + + if (IM_PIXTYPE(im) != TY_USHORT) { + call fxf_filter_keyw (im, "BSCALE") + call fxf_filter_keyw (im, "BZERO") + } + + # Hdr_size is in char units. (i.e. 1440 chars per FITS block). + hdr_size = fxf_header_size (im) + + # Reset the scaling parameter because in NEW_COPY mode there + # should not be scaled pixels. The previous call will get these + # values from the input image. + + FIT_BSCALE(fit) = 1.0d0 + FIT_BZERO(fit) = 0.0d0 + + sz_pixfile = npix * pix_size[IM_PIXTYPE(im)] + + # The pixel file needs to be a multiple of 1440 chars. + sz_pixfile = FITS_LEN_CHAR (sz_pixfile) + sz_fitfile = sz_pixfile + hdr_size + + if (FIT_NEWIMAGE(fit) == YES) + call falloc (IM_PIXFILE(im), sz_fitfile) + + FIT_IM(fit) = im + + iferr (IM_PFD(im) = fopnbf (pathname, READ_WRITE, + fxfzop, fxfzrd, fxfzwr, fxfzwt, fxfzst, fxfzcl)) { + IM_PFD(im) = NULL + call erract (EA_FATAL) + goto err_ + } + + FIT_PFD(fit) = IM_PFD(im) + filesize = fstatl (IM_PFD(im), F_FILESIZE) + FIT_EOFSIZE(fit) = filesize + 1 + + if (FIT_NEWIMAGE(fit) == NO) { + # Now we are appending a new IMAGE extension. + # Write a blank header in order to append the + # pixels after it. + + pixoff = filesize + hdr_size + 1 + + # Update the offset for the blank write to follow which uses + # a local file driver tied to the IM_PFD descriptor and not + # the normal FIO. + FIT_PIXOFF(fit) = pixoff + + # Update filesize + filesize = filesize + sz_fitfile + call fxf_write_blanks (IM_PFD(im), hdr_size) + } else + pixoff = hdr_size + 1 + + FIT_PIXOFF(fit) = pixoff + call imioff (im, pixoff, compress, blklen) + + IM_HFD(im) = NULL + + default: + call imerr (IM_NAME(im), SYS_IMACMODE) + } + +endowr_ + FIT_PFD(fit) = IM_PFD(im) + FIT_HFD(fit) = IM_HFD(im) + + # The following statement is to pass the datatype at the low + # level fits read and write routines. The datatype value can + # change after the image is open. Hopefully the value of 'im' + # will remain static. + + FIT_IM(fit) = im + status = OK + + call sfree (sp) + return +err_ + status = ERR + call sfree (sp) +end + + +# FXF_HEADER_SIZE -- Function to calculate the header size that would go +# into the output file extension. + +int procedure fxf_header_size (im) + +pointer im #I Image descriptor + +bool inherit +int merge, hdr_size +pointer op, fit, sp, tb, pb +int nheader_cards, ualen, ulines, clines +int strlen() + +begin + fit = IM_KDES(im) + inherit = false + + # Fks_inherit is a combined value. + if (FKS_INHERIT(fit) == YES) + inherit = true + + call fxf_mandatory_cards (im, nheader_cards) + + if (FIT_NEWIMAGE(fit) == NO && inherit) { + # See if current UA keywords are in the global header, if not + # there put it in a spool file. At the end, the spool file size is + # the output extension header size to be use in fitupdhdr. + + # Check if the file is still in cache. We need CACHELEN and + # CACHEHDR. + + call fxf_not_incache (im) + + op = IM_USERAREA(im) + ualen = strlen (Memc[op]) + ulines = ualen / LEN_UACARD + clines = FIT_CACHEHLEN(fit) / LEN_UACARD + + call smark (sp) + call salloc (tb, ualen+1, TY_CHAR) + + merge = NO + pb = tb + + # Now select those lines from the UA (pointed by op) that are + # not in the cache and accumulate them in 'pb'. + + call fxf_match_str (op, ulines, FIT_CACHEHDR(fit), clines,merge,pb) + Memc[pb+1] = EOS + ualen = strlen (Memc[tb]) + + call sfree (sp) + + } else { + op = IM_USERAREA(im) + ualen = strlen (Memc[op]) + } + + ulines = ualen / LEN_UACARD + nheader_cards + FKS_PADLINES(fit) + + ##### Note: PHULINES is not currently used, should be implemented + ##### Not clear to me if this code here is used for the PHU since + ##### it is in opix! + + # See if the application has set a minumum number of card for the UA. + + ulines = max (ulines, FKS_EHULINES(fit)) + + # The user area contains new_lines (81 chars, LEN_UACARD). Scale to + # 80 chars (LEN_CARD). Ualen is in bytes. + + ualen = ulines * LEN_CARD + + # Calculate the number of header FITS blocks in chars. + hdr_size = FITS_LEN_CHAR (ualen / 2) + + return (hdr_size) +end + + +# FXF_BYTE_SHORT -- This routine is obsolete and has been deleted, but is +# being preserved for the V2.11.2 patch so that a new shared library version +# does not have to be created. It can be deleted in the next major release. + +procedure fxf_byte_short (im, fname) + +pointer im +char fname[ARB] + +begin +end + + +# FXF_WRITE_BLANKS --Procedure to append a blank header to an existing +# file, preparing to write data after it. + +procedure fxf_write_blanks (fd, size) + +int fd #I File descriptor +int size #I New size (chars) to allocate. + +pointer sp, bf +int nblocks,i, fits_lenc + +begin + call smark (sp) + + # Length of a FITS block (2880) in chars. + fits_lenc = FITS_BLOCK_BYTES/SZB_CHAR + call salloc (bf, fits_lenc, TY_INT) + call amovki (0, Memi[bf], fits_lenc) + + size = FITS_LEN_CHAR(size) + nblocks = size / fits_lenc + + call seek (fd, EOF) + do i = 1, nblocks + call write (fd, Memi[bf], fits_lenc) + + call sfree (sp) +end + + +# FXF_MANDATORY_CARDS -- Count the required FITS header cards. +# The cards for the Main Unit are: SIMPLE, BITPIX, NAXIS, +# EXTEND, ORIGIN, DATE, IRAF_TLM, OBJECT and END; +# 'IM_NDIM(im)', DATAMIN and DATAMAX will be put out +# only if the LIMTIME > MTIME. +# would take care of NAXISi. For an Extension unit, the cards are: +# XTENSION, BITPIX, NAXIS, PCOUNT, GCOUNT, ORIGIN, DATE, INHERIT, +# EXTNAME, IRAF_TLM, OBJECT and END; IM_NDIM(im) takes care of +# NAXISi. Same as above for DATAMIN, DATAMAX. +# If these cards are in the main header, reduce the number of +# mandatory cards that are going to be created at closing time +# (in fitupdhdr). + +procedure fxf_mandatory_cards (im, nheader_cards) + +pointer im #I im structure +int nheader_cards #O Number of mandatory cards in header. + +pointer ua +int ncards, rp, fit, acmode +int idb_findrecord() + +begin + ua = IM_USERAREA(im) + fit = IM_KDES(im) + + if (FIT_NEWIMAGE(fit) == YES) # create a PHU + ncards = 9 + IM_NDIM(im) + else # create an EHU + ncards = 12 + IM_NDIM(im) + + if (idb_findrecord (im, "PCOUNT", rp) > 0) { + if (FIT_XTENSION(fit) == YES) + ncards = ncards - 1 + else + call fxf_filter_keyw (im, "PCOUNT") + } + if (idb_findrecord (im, "GCOUNT", rp) > 0) { + if (FIT_XTENSION(fit) == YES) + ncards = ncards - 1 + else + call fxf_filter_keyw (im, "GCOUNT") + } + if (idb_findrecord (im, "EXTNAME", rp) > 0) { + if (FIT_XTENSION(fit) == YES) + ncards = ncards - 1 + else + call fxf_filter_keyw (im, "EXTNAME") + } + if (idb_findrecord (im, "INHERIT", rp) > 0) { + if (FIT_XTENSION(fit) == YES) + ncards = ncards - 1 + else + call fxf_filter_keyw (im, "INHERIT") + } + if (idb_findrecord (im, "EXTEND", rp) > 0) { + if (FIT_XTENSION(fit) == NO) { + ncards = ncards - 1 + } else { + # Delete the keyword from the UA because EXTEND is not + # recommended in XTENSION units. + + call fxf_filter_keyw (im, "EXTEND") + } + } + + if (idb_findrecord (im, "ORIGIN", rp) > 0) + ncards = ncards - 1 + if (idb_findrecord (im, "DATE", rp) > 0 ) + ncards = ncards - 1 + if (idb_findrecord (im, "IRAF-TLM", rp) > 0) + ncards = ncards - 1 + if (idb_findrecord (im, "OBJECT", rp) > 0) + ncards = ncards - 1 + + # See if we need to add one more mandatory card when an EXTVER value + # was specified when appending a new extension. + + if (FIT_NEWIMAGE(fit) == NO && idb_findrecord(im,"EXTVER",rp) == 0) { + # Keyword does not exist. + acmode = IM_ACMODE(im) + if ((acmode == NEW_IMAGE || acmode == NEW_COPY) && + FKS_EXTVER(fit) != INDEFL ) + ncards = ncards + 1 + } + + # We want to keep BSCALE and BZERO in the UA in case we are + # editing the values. Is up to the user or application + # responsability to deal with the change in pixel value when reading. + # If we are reading pixels the values will change according to the + # input BSCALE and BZERO. If we are adding BSCALE and BZERO before + # accessing any pixels, these will get scale. If adding or + # changing right before closing the image, the pixel value will be + # unchanged. + + # See if BSCALE and BZERO are in the UA for ushort, otherwise + # increase the number. + + if (IM_PIXTYPE(im) == TY_USHORT) { + if (idb_findrecord (im, "BSCALE", rp) == 0) + ncards = ncards + 1 + if (idb_findrecord (im, "BZERO", rp) == 0) + ncards = ncards + 1 + } + nheader_cards = ncards +end + + +# FXF_OVERWRITE_UNIT -- Overwrite an existent extension. A temporary file +# is created that contains the current file upto the extension before the +# one to be overwrite. + +procedure fxf_overwrite_unit (fit, im) + +pointer fit #I Fits descriptor +pointer im #I Image descriptor + +pointer sp, file, mii +int pixoff, compress, blklen, sz_fitfile, i, group, filesize +int junk, in_fd, out_fd, nblocks, nk, hdr_size, sz_pixfile +extern fxfzop(), fxfzrd(), fxfzwr(), fxfzwt(), fxfzst(), fxfzcl() +int fnroot(), open(), read(), fxf_totpix(), strncmp(), itoc() +int strlen(), fopnbf(), fstatl(), fxf_header_size() + +include <szpixtype.inc> + +errchk syserr, syserrs +define err_ 91 + +begin + group = FIT_GROUP(fit) + + # Do not overwrite extensions that are not IMAGE. + if (group != 0 && strncmp (FIT_EXTTYPE(fit), "IMAGE", 5) != 0 && + strncmp (FIT_EXTTYPE(fit), "SIMPLE", 6) != 0) { + + call syserr (SYS_FXFOVRBEXTN) + return + } + + call smark (sp) + call salloc (file, SZ_FNAME, TY_CHAR) + call salloc (mii, FITS_BLOCK_CHARS, TY_INT) + + junk = fnroot (IM_HDRFILE(im), Memc[file], SZ_FNAME) + + # Keep the temporary filename in IM_PIXFILE(im). + call mktemp (Memc[file], IM_PIXFILE(im), SZ_PATHNAME) + call strcat (".fits", IM_PIXFILE(im), SZ_PATHNAME) + + # If we want to overwrite the first group there is nothing + # to copy first. + + if (group != 0) { + # Copy from the old file up to hdr_off[group] into a temporary file. + in_fd = open (IM_HDRFILE(im), READ_ONLY, BINARY_FILE) + out_fd = open (IM_PIXFILE(im), NEW_FILE, BINARY_FILE) + nblocks = Memi[FIT_HDRPTR(fit)+group]/ FITS_BLOCK_CHARS + do nk = 1, nblocks { + junk = read (in_fd, Memi[mii], FITS_BLOCK_CHARS) + call write (out_fd, Memi[mii], FITS_BLOCK_CHARS) + } + call close (in_fd) + call close (out_fd) + } + + FIT_NAXIS(fit) = IM_NDIM(im) + call amovi (IM_LEN(im,1), FIT_LENAXIS(fit,1), IM_NDIM(im)) + + FIT_TOTPIX(fit) = fxf_totpix(im) + + # Do not allow BSCALE and BZERO in the UA when making a new copy or + # new image if bitpix is negative. Except for ushort. + + if (IM_PIXTYPE(im) != TY_USHORT) { + call fxf_filter_keyw (im, "BSCALE") + call fxf_filter_keyw (im, "BZERO") + } + + # The new copy header should not have the following keywords: + # GROUPS, PSIZE and that could come from a GEIS file. + + call fxf_discard_keyw (im) + hdr_size = fxf_header_size (im) + + # Reset the scaling parameter because in NEW_COPY mode there + # should not be scaled pixels. The previous call will get these + # values from the input image. + + FIT_BSCALE(fit) = 1.0d0 + FIT_BZERO(fit) = 0.0d0 + + call fpathname (IM_PIXFILE(im), Memc[file], SZ_PATHNAME) + call strcat("_", Memc[file], SZ_PATHNAME) + i = strlen(Memc[file]) + junk = itoc (fit, Memc[file+i], SZ_PATHNAME) + + # The pixel file needs to be a multiple of 1440 chars. + sz_pixfile = fxf_totpix(im) * pix_size[IM_PIXTYPE(im)] + sz_pixfile = FITS_LEN_CHAR(sz_pixfile) + sz_fitfile = sz_pixfile + hdr_size + + if (group == 0) + call falloc (IM_PIXFILE(im), sz_fitfile) + + FIT_IM(fit) = im + iferr (IM_PFD(im) = fopnbf (Memc[file], READ_WRITE, + fxfzop, fxfzrd, fxfzwr, fxfzwt, fxfzst, fxfzcl)) { + + IM_PFD(im) = NULL + goto err_ + } + + filesize = fstatl (IM_PFD(im), F_FILESIZE) + FIT_EOFSIZE(fit) = filesize + 1 + # Now write a blank header. + if (group != 0) { + call amovki (0, Memi[mii], FITS_BLOCK_CHARS) + nblocks = hdr_size/FITS_BLOCK_CHARS + FIT_HFD(fit) = -1 + + call seek (IM_PFD(im), EOF) + do nk = 1, nblocks + call write (IM_PFD(im), Memi[mii], FITS_BLOCK_CHARS) + + pixoff = filesize + hdr_size + 1 + filesize = filesize + sz_fitfile + } else + pixoff = hdr_size + 1 + + + FIT_PIXOFF(fit) = pixoff + IM_HFD(im) = NULL + + blklen = 1 + compress = YES + call imioff (im, pixoff, compress, blklen) + + FIT_PFD(fit) = IM_PFD(im) + FIT_HFD(fit) = IM_HFD(im) + + call sfree (sp) + return +err_ + call syserr (SYS_FXFOVRTOPN) + call sfree (sp) +end + + +# TOTPIX -- Calculate the total number of pixels in the image. + +int procedure fxf_totpix (im) + +pointer im #I image descriptor +int i, pix, ndim + +begin + ndim = IM_NDIM(im) + if (ndim == 0) + return (0) + + pix = IM_LEN(im,1) + do i = 2, ndim + pix = pix * IM_LEN(im,i) + + return (pix) +end + + +# FXF_DISCARD_FITS_KEYW -- Exclude certain keywords from a new copy image. + +procedure fxf_discard_keyw (im) + +pointer im #I image descriptor +pointer fit + +begin + fit = IM_KDES(im) + + call fxf_filter_keyw (im, "GROUPS") + call fxf_filter_keyw (im, "PSIZE") + call fxf_filter_keyw (im, "BLOCKED") + call fxf_filter_keyw (im, "IRAFNAME") + call fxf_filter_keyw (im, "IRAF-BPX") + call fxf_filter_keyw (im, "IRAFTYPE") + + if (FIT_NEWIMAGE(fit) == NO) + call fxf_filter_keyw (im, "EXTEND") + + # Create a PHU. + if (FIT_NEWIMAGE(fit) == YES) { + call fxf_filter_keyw (im, "PCOUNT") + call fxf_filter_keyw (im, "GCOUNT") + call fxf_filter_keyw (im, "INHERIT") + call fxf_filter_keyw (im, "EXTNAME") + call fxf_filter_keyw (im, "EXTVER") + call fxf_filter_keyw (im, "EXTLEVEL") + } +end + + +# FXF_FILTER_KEYW -- Delete the names keyword from the userarea. + +procedure fxf_filter_keyw (im, key) + +pointer im #I image descriptor +char key[ARB] #I keyword name to delete from USERAREA. + +pointer rp +int off +int idb_findrecord(), stridxs() + +begin + # Verify that the named user field exists. + if (idb_findrecord (im, key, rp) <= 0) + return + + # Delete the field. + off = stridxs ("\n", Memc[rp]) + if (off > 0) + call strcpy (Memc[rp+off], Memc[rp], ARB) + else + Memc[rp] = EOS +end + + +# FXF_FALLOC -- Preallocate space on disk by writing blanks. + +procedure fxf_falloc (fname, size) + +char fname[ARB] #I filename +int size #I size to preallocate in chars + +pointer sp, cp +int nb,i, fd +errchk open, write +int open() + +begin + call smark (sp) + call salloc (cp, FITS_BLOCK_CHARS, TY_CHAR) + + call amovkc (' ', Memc[cp], FITS_BLOCK_CHARS) + nb = size / FITS_BLOCK_CHARS + fd = open (fname, NEW_FILE, BINARY_FILE) + + do i = 1, nb + call write (fd, Memc[cp], FITS_BLOCK_CHARS) + + call flush (fd) + call close (fd) + call sfree (sp) +end + + +# FXF_CKH_NDIM -- Check that the application has indeed set the number +# of dimension, otherwise count the axes. + +procedure fxf_chk_ndim (im) + +pointer im #I imio descriptor +int ndim #I number of dimension for image + +begin + ndim = IM_NDIM(im) + + # If ndim was not explicitly set, compute it by counting the number + # of nonzero dimensions. + + if (ndim == 0) { + for (ndim=1; IM_LEN(im,ndim) > 0 && ndim <= IM_MAXDIM; ndim=ndim+1) + ; + ndim = ndim - 1 + IM_NDIM(im) = ndim + } +end + + +# FXF_NOT_INCACHE -- Procedure to find whether the file is in the +# cache. It could happen that the slot with the entry might have been +# freed to make room for another file. We want to have valid pointers +# for FIT_CACHEHDR and FIT_CACHELEN since the calling routine will use them. + +procedure fxf_not_incache (im) + +pointer im #I image descriptor + +int cindx, group, sfit[4] +pointer sp, hdrfile, fit +bool streq() + +include "fxfcache.com" + +begin + call smark (sp) + call salloc (hdrfile, SZ_PATHNAME, TY_CHAR) + + call fpathname (IM_HDRFILE(im), Memc[hdrfile], SZ_PATHNAME) + fit = IM_KDES(im) + + do cindx=1, rf_cachesize { + if (rf_fit[cindx] == NULL) + next + + if (streq (Memc[hdrfile], rf_fname[1,cindx])) { + call sfree (sp) + return + } + } + sfit[1]= FIT_NAXIS(fit) + sfit[2] = FIT_INHERIT(fit) + sfit[3] = FIT_PLMAXLEN(fit) + sfit[4] = IM_CTIME(im) + + group = max (0, FIT_GROUP(fit)) + + call fxf_prhdr(im,group) + + FIT_NAXIS(fit) = sfit[1] + FIT_INHERIT(fit) = sfit[2] + FIT_PLMAXLEN(fit) = sfit[3] + IM_CTIME(im) = sfit[4] + + call sfree (sp) + return +end + diff --git a/sys/imio/iki/fxf/fxfpak.x b/sys/imio/iki/fxf/fxfpak.x new file mode 100644 index 00000000..01db148d --- /dev/null +++ b/sys/imio/iki/fxf/fxfpak.x @@ -0,0 +1,58 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <mach.h> +include "fxf.h" + + +# FXF_PAK_DATA -- Convert npix elements of type pixtype as needed for storage +# in a FITS file. All floating point data will be converted to IEEE format. +# The input and output buffers may be the same if desired. + +procedure fxf_pak_data (ibuf, obuf, npix, pixtype) + +char ibuf[ARB] #I input data buffer +char obuf[ARB] #I output data buffer +int npix #I number of pixels in buffer +int pixtype #I input pixel datatype + +int nbytes, nchars +errchk syserr + +include <szpixtype.inc> + +begin + ### Possibly the MII conversion routines should be used here as + ### they handle all these datatypes (except maybe ushort). + + nchars = npix * pix_size[pixtype] + nbytes = nchars * SZB_CHAR + + switch (pixtype) { + case TY_USHORT: + call fxf_altmu (ibuf, obuf, npix) + if (BYTE_SWAP2 == YES) + call bswap2 (obuf, 1, obuf, 1, nbytes) + + case TY_SHORT: + if (BYTE_SWAP2 == YES) + call bswap2 (ibuf, 1, obuf, 1, nbytes) + else + call amovc (ibuf, obuf, nchars) + + case TY_INT, TY_LONG: + if (BYTE_SWAP4 == YES) + call bswap4 (ibuf, 1, obuf, 1, nbytes) + else + call amovc (ibuf, obuf, nchars) + + case TY_REAL: + call ieevpakr (ibuf, obuf, npix) + + case TY_DOUBLE: + call ieevpakd (ibuf, obuf, npix) + + default: + call syserr (SYS_FXFPKDTYP) + } +end diff --git a/sys/imio/iki/fxf/fxfplread.x b/sys/imio/iki/fxf/fxfplread.x new file mode 100644 index 00000000..4d4c3e83 --- /dev/null +++ b/sys/imio/iki/fxf/fxfplread.x @@ -0,0 +1,160 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <plset.h> +include <imhdr.h> +include <imio.h> +include <mach.h> +include "fxf.h" + + +# FXF_PLREAD -- Read a PLIO mask stored in a FITS binary table extension +# and load it into an image descriptor. +# +# There is a builtin assumption in this code (also in fxf_plwrite) that +# masks will not be more than 3-dimensional. This could be generalized +# if necessary, but we have never seen a mask of dimensionality higher +# than 3. The dimensionality, size, and depth of the mask is preserved. + +procedure fxf_plread (im) + +pointer im #I image descriptor + +char kwname[SZ_KEYWORD] +pointer sp, fk, pl, lp, ip, ix +long data_offset, data_len, heap_offset, llen, loff +int naxes, axlen[IM_MAXDIM], depth, maxlen +int fd, i, j, nelem, nlines, v[PL_MAXDIM], maxoff, nbytes + +long note() +bool streq() +int imgeti(), pl_create(), miireadi(), miireads() +errchk imgeti, pl_create, miireadi, miireads, seek, pl_update, syserrs + +begin + call smark (sp) + + fk = IM_KDES(im) + fd = IM_HFD(im) + + # The maximum encoded line list length is (normally) passed in via + # the binary table format keywords, and stored in FIT_PLMAXLEN. + + maxlen = FIT_PLMAXLEN(fk) + if (maxlen <= 0) + maxlen = DEF_PLMAXLEN + + # Scratch buffer for encoded line lists. + call salloc (lp, maxlen, TY_SHORT) + + # Get the dimensionality and size of the stored mask. + call amovki (1, axlen, IM_MAXDIM) + naxes = imgeti (im, "ZNAXIS") + call fxf_filter_keyw (im, "ZNAXIS") + do i = 1, naxes { + call sprintf (kwname, LEN_CARD, "ZNAXIS%d") + call pargi(i) + axlen[i] = imgeti (im, kwname) + call fxf_filter_keyw (im, kwname) + call sprintf (kwname, LEN_CARD, "ZTILE%d") + call pargi(i) + call fxf_filter_keyw (im, kwname) + } + + # Get the mask depth, passed as compression algorithm parameter + # number 1 for a PLIO-compressed image. + + depth = DEF_PLDEPTH + ifnoerr (call imgstr (im, "ZNAME1", kwname, SZ_KEYWORD)) { + if (streq (kwname, "depth")) + iferr (depth = imgeti (im, "ZVAL1")) + depth = DEF_PLDEPTH + call fxf_filter_keyw (im, "ZNAME1") + call fxf_filter_keyw (im, "ZVAL1") + call fxf_filter_keyw (im, "ZBITPIX") + call fxf_filter_keyw (im, "ZIMAGE") + } + + # Create an initially empty mask of the given size. + pl = pl_create (naxes, axlen, depth) + + # Create a buffer for the line list index (maxdim 3 assumed). + nlines = axlen[3] * axlen[2] + call salloc (ix, nlines * 2, TY_INT) + + # Compute the file offsets of the table data and heap areas. The + # file position is assumed to be already positioned at the start + # of the data area of the file. + + data_offset = note (fd) + data_len = FIT_LENAXIS(fk,3) * FIT_LENAXIS(fk,2) * FIT_LENAXIS(fk,1) + heap_offset = data_offset + data_len/SZB_CHAR + + # Read the line list index from the input file. The index contains + # one entry for every line in the (possibly multidimensional) image. + # Each entry consists of two integer values, the length of the + # stored line list, and the heap offset (in bytes) of the stored list. + + nelem = miireadi (fd, Memi[ix], nlines * 2) + if (nelem != nlines * 2) + call syserrs (SYS_FXFRMASK, IM_NAME(im)) + + # Find out the maximum offset value to determine if they were + # written using the 2 byte units rather than the standard (byte unit) + + maxoff = 0 + ip = ix + do j = 1, axlen[3] { + do i = 1, axlen[2] { + maxoff = max (maxoff, Memi[ip+1]+2*Memi[ip]) + ip = ip + 2 + } + } + + if (maxoff < (FIT_PCOUNT(fk) - maxoff/2)) { + nbytes = 1 + } else { + nbytes = 2 + } + + # Read the line list data and insert it into the PLIO mask. + # pl_update will be called for each line of the mask even if multiple + # lines point to the same line list data, but pl_update will sort + # all this out and restore the multiple references as the mask is + # built. + + ip = ix + v[1] = 1 + + do j = 1, axlen[3] { + v[3] = j + do i = 1, axlen[2] { + v[2] = i + + llen = Memi[ip] + + # This offset on the table data is in byte units, convert + # to short. + + loff = Memi[ip+1] / nbytes + + call seek (fd, heap_offset + loff) + nelem = miireads (fd, Mems[lp], llen) + if (nelem != llen) + call syserrs (SYS_FXFRMASK, IM_NAME(im)) + + call pl_update (pl, v, Mems[lp]) + + ip = ip + 2 + } + } + + # Set up IMIO descriptor. + call amovl (axlen, IM_LEN(im,1), IM_MAXDIM) + call amovl (axlen, IM_PHYSLEN(im,1), IM_MAXDIM) + IM_NDIM(im) = naxes + IM_PIXTYPE(im) = TY_INT + IM_PL(im) = pl + + call sfree (sp) +end diff --git a/sys/imio/iki/fxf/fxfplwrite.x b/sys/imio/iki/fxf/fxfplwrite.x new file mode 100644 index 00000000..65909dcb --- /dev/null +++ b/sys/imio/iki/fxf/fxfplwrite.x @@ -0,0 +1,418 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <mach.h> +include <imio.h> +include <imhdr.h> +include <mii.h> +include <plset.h> +include <pmset.h> +include "fxf.h" + + +# FXFPLWRITE.X -- Routines to handle masks in FITS extensions. +# +# fxf_plwrite (im, fd) +# fxf_plinfo (im, maxlen, pcount, depth) +# fxf_pl_adj_heap (im, hdr_fd, pcount) +# fxf_copy_adj (im, in_fd, hdroff, poff, datasize) +# fxf_plpf (im) +# + + +# FXF_PLWRITE -- Write the data from a PLIO mask into the data area of a +# FITS compressed image (ZIMAGE) binary table extension. The data is +# written to the file pointed to by file descriptor FD. +# +# The data to be written consists of the data for the ZIMAGE binary table +# records, followed by the heap area of the BINTABLE extension, which +# contains the actual encoded line lists. For simplicity we assume that +# the table contains only one column, the COMPRESSED_DATA column, which is +# of type variable length integer array. Each element of this column is a +# BINTABLE variable length array descriptor which physically consists of two +# integer values: an integer giving the length of the stored array (encoded +# line list), followed by an integer (in byte unit) giving the offset of +# the array data (encoded line list) in the heap area. Multiple variable +# length array descriptors may point to the same stored array, and in +# fact PLIO uses this feature to implement compression in the Y direction +# (adjacent mask lines will point to the same encoded line list). +# The code here supports masks of up to 3 dimensions. + +procedure fxf_plwrite (im, fd) + +pointer im #I image descriptor +int fd #I output file descriptor + +int i, j, v_in[PL_MAXDIM], lp_len +int naxes, axlen[PL_MAXDIM], depth +int heap_offset, ep_off, lp_off, vararray[2] +pointer pl, lp, op, emptyline, lastline + +int pl_llen() +pointer pl_access(), pl_emptyline() +errchk pl_access + +begin + pl = IM_PL(im) + call pl_gsize (pl, naxes, axlen, depth) + + # Write the COMPRESSED_DATA table column. This is an index giving + # the length and heap offset of the encoded PLIO line list for each + # line of the image. Multiple image lines (index entries) may point + # to the same stored line list: this happens if a mask line is empty + # (the empty line) or if successive lines are all the same. For the + # sake of simplicity, only masks of up to 3 dimensions are supported. + + op = 0 + heap_offset = 0 + emptyline = pl_emptyline (pl) + ep_off = -1 + lastline = NULL + lp_off = -1 + call amovkl(long(1), v_in, PL_MAXDIM) + + do j = 1, axlen[3] { + v_in[3] = j + do i = 1, axlen[2] { + v_in[2] = i + lp = pl_access (pl, v_in) + lp_len = pl_llen (Mems[lp]) + + if (lp == emptyline && ep_off >= 0) + op = ep_off + else if (lp == lastline) + op = lp_off + else + op = heap_offset + + vararray[1] = lp_len + + # The offsets on the FITS BINTABLE is in byte unit + # as establish by the FITS standard. + + vararray[2] = op * 2 # Byte offset + + call miiwritei (fd, vararray, 2) + + lastline = lp + lp_off = op + if (lp == emptyline && ep_off < 0) + ep_off = op + + if (op == heap_offset) + heap_offset = heap_offset + lp_len + } + } + # Now write the line list data to the heap area. The logic here must + # follow that above or the line offsets won't match. + + ep_off = -1 + lp_off = -1 + lastline = NULL + + do j = 1, axlen[3] { + v_in[3] = j + do i = 1, axlen[2] { + v_in[2] = i + lp = pl_access (pl, v_in) + lp_len = pl_llen (Mems[lp]) + + if (lp == emptyline && ep_off >= 0) + next + else if (lp == lastline) + next + + call miiwrites (fd, Mems[lp], lp_len) + + lastline = lp + if (lp == emptyline && ep_off < 0) + ep_off = 0 + } + } +end + + +# FXF_PLINFO -- Examine a PLIO mask and compute the maximum length of an +# encoded line list, and the storage in bytes required to store the mask +# data in the heap area of a FITS binary table. + +procedure fxf_plinfo (im, maxlen, pcount, depth) + +pointer im #I image descriptor +int maxlen #O maximum line list length +int pcount #O storage required to store mask (bytes) +int depth #O mask depth + +int naxes, axlen[PL_MAXDIM] +int i, j, v_in[PL_MAXDIM], lp_len +int heap_offset, ep_off, lp_off +pointer pl, lp, op, emptyline, lastline + +int pl_llen() +pointer pl_access(), pl_emptyline() +errchk pl_access + +begin + pl = IM_PL(im) + call pl_gsize (pl, naxes, axlen, depth) + + op = 0 + maxlen = 0 + heap_offset = 0 + emptyline = pl_emptyline (pl) + ep_off = -1 + lastline = NULL + lp_off = -1 + call amovkl(long(1), v_in, PL_MAXDIM) + + # The following must duplicate the logic above for determining what + # gets written to the heap area. All we are doing here is computing + # the amount of heap storage required to store the compressed mask. + + do j = 1, axlen[3] { + v_in[3] = j + do i = 1, axlen[2] { + v_in[2] = i + lp = pl_access (pl, v_in) + lp_len = pl_llen (Mems[lp]) + maxlen = max (maxlen, lp_len) + + if (lp == emptyline && ep_off >= 0) + op = ep_off + else if (lp == lastline) + op = lp_off + else + op = heap_offset + + lastline = lp + lp_off = op + if (lp == emptyline && ep_off < 0) + ep_off = op + + if (op == heap_offset) + heap_offset = heap_offset + lp_len + } + } + + pcount = heap_offset * (SZ_SHORT * SZB_CHAR) +end + + +# FXF_PL_ADJ_HEAP -- Resize heap when we have a hole bigger than 2880 bytes +# or if we overwrite the next extension. + +procedure fxf_pl_adj_heap (im, hdr_fd, pcount) + +pointer im #I imio descriptor +int hdr_fd #U file descriptor +int pcount #I new heap size in bytes + +pointer fk, hdrp, pixp +int datasize, hdroff, diff, nb, group, i + +begin + fk = IM_KDES(im) + + # Calculate the size of the TABLE data. (8 bytes per line) + datasize = FIT_LENAXIS(fk,1)*FIT_LENAXIS(fk,2)* + FIT_LENAXIS(fk,3) + datasize = (datasize + pcount)/SZB_CHAR + + call fxf_not_incache(im) + hdrp = FIT_HDRPTR(fk) + pixp = FIT_PIXPTR(fk) + group = FIT_GROUP(fk) + + hdroff = Memi[hdrp+group] + + # Calculate the amount of space left or grown in the heap + # as a result of the READ-WRITE operation on the data. + + diff = datasize - (Memi[hdrp+group+1] - Memi[pixp+group]) + + # See if the new data overwrites the next unit or + # there is a hole with more than 2880 bytes. + + if ( (diff > 0) || ((-diff / 2880) > 0) ) { + + # Adjust the header and pixel offset for subsequent groups. + # Add header size. + datasize = datasize + Memi[pixp+group] - Memi[hdrp+group] + call fxf_copy_adj (im, hdr_fd, hdroff, Memi[hdrp+group+1], datasize) + + if (diff > 0) + nb = FITS_LEN_CHAR (diff) + else + nb = (diff / 1440) * 1440 + + # Update FK cache offset values + do i = group+1, FIT_NUMOFFS(fk) { + Memi[hdrp+i] = Memi[hdrp+i] + nb + if (Memi[pixp+i] > 0) { + Memi[pixp+i] = Memi[pixp+i] + nb + } else + break + } + } +end + + +# FXF_COPY_ADJ -- Make a copy of the input file extending or shrinking +# the heap area. + +procedure fxf_copy_adj (im, in_fd, hdroff, poff, datasize) + +pointer im #I Imio descriptor +int in_fd #I Input file descriptor +int hdroff #I Header offset +int poff #I Pixel offset +int datasize #I New FITS unit size + +pointer sp, tempfile, outname +int nchars, junk, inoff, out_fd, size +int fnldir(), fnroot(), open(), note() +errchk open, note, seek, close, delete, rename +errchk fxf_make_adj_copy, fxf_write_blanks + +begin + call smark (sp) + call salloc (tempfile, SZ_FNAME, TY_CHAR) + call salloc (outname, SZ_FNAME, TY_CHAR) + + nchars = fnldir (IM_HDRFILE(im), Memc[tempfile], SZ_FNAME) + junk = fnroot (IM_HDRFILE(im), Memc[tempfile+nchars], SZ_FNAME) + call mktemp (Memc[tempfile], Memc[outname], SZ_PATHNAME) + call strcat (".fits", Memc[outname], SZ_PATHNAME) + + inoff = note (in_fd) + out_fd = open (Memc[outname], NEW_FILE, BINARY_FILE) + + call fxf_make_adj_copy (in_fd, out_fd, hdroff, poff, datasize) + + # Pad to 2880 bytes block + size = note (out_fd) - 1 + size = mod(size, FITS_BLOCK_CHARS) + if (size != 0) { + size = FITS_BLOCK_CHARS - size + call fxf_write_blanks (out_fd, size) + } + + size = note (out_fd) - 1 + call close (in_fd) + call delete (IM_HDRFILE(im)) + call rename (Memc[outname], IM_HDRFILE(im)) + + in_fd = out_fd + call seek (in_fd, inoff) + call sfree (sp) +end + + +# FXF_PLPF -- Initialize IMIO dependencies when dealing with a PLIO +# image mask. + +procedure fxf_plpf (im) + +pointer im #I IMIO descriptor + +int pfd +pointer sp, imname, ref_im +int sv_acmode, sv_update, ndim, i, depth +errchk iki_opix, open +int open() + +begin + call smark (sp) + call salloc (imname, SZ_IMNAME, TY_CHAR) + + # Complete the initialization of a mask image. + ref_im = IM_PLREFIM(im) + + sv_acmode = IM_ACMODE(im) + sv_update = IM_UPDATE(im) + call strcpy (IM_NAME(im), Memc[imname], SZ_IMNAME) + + if (ref_im != NULL) { + # Create a mask the same size as the physical size of the + # reference image. Inherit any image section from the + # reference image. + + IM_NDIM(im) = IM_NDIM(ref_im) + IM_NPHYSDIM(im) = IM_NPHYSDIM(ref_im) + IM_SECTUSED(im) = IM_SECTUSED(ref_im) + call amovl (IM_LEN(ref_im,1), IM_LEN(im,1), IM_MAXDIM) + call amovl (IM_PHYSLEN(ref_im,1),IM_PHYSLEN(im,1),IM_MAXDIM) + call amovl (IM_SVLEN(ref_im,1), IM_SVLEN(im,1), IM_MAXDIM) + call amovl (IM_VMAP(ref_im,1), IM_VMAP(im,1), IM_MAXDIM) + call amovl (IM_VOFF(ref_im,1), IM_VOFF(im,1), IM_MAXDIM) + call amovl (IM_VSTEP(ref_im,1), IM_VSTEP(im,1), IM_MAXDIM) + + # Tell PMIO to use this image as the reference image. + call pm_seti (IM_PL(im), P_REFIM, im) + + } else if (sv_acmode == NEW_IMAGE || sv_acmode == NEW_COPY) { + # If ndim was not explicitly set, compute it by counting + # the number of nonzero dimensions. + + ndim = IM_NDIM(im) + if (ndim == 0) { + ndim = 1 + while (IM_LEN(im,ndim) > 0 && ndim <= IM_MAXDIM) + ndim = ndim + 1 + ndim = ndim - 1 + IM_NDIM(im) = ndim + } + + # Make sure dimension stuff makes sense. + if (ndim < 0 || ndim > IM_MAXDIM) + call imerr (IM_NAME(im), SYS_IMNDIM) + + do i = 1, ndim + if (IM_LEN(im,i) <= 0) + call imerr (IM_NAME(im), SYS_IMDIMLEN) + + # Set the unused higher dimensions to 1. This makes it + # possible to access the image as if it were higher + # dimensional, and in a way it truely is. + + do i = ndim + 1, IM_MAXDIM + IM_LEN(im,i) = 1 + + IM_NPHYSDIM(im) = ndim + call amovl (IM_LEN(im,1), IM_PHYSLEN(im,1), IM_MAXDIM) + call amovl (IM_LEN(im,1), IM_SVLEN(im,1), IM_MAXDIM) + if (sv_acmode == NEW_IMAGE) + call amovkl (long(1), IM_VSTEP(im,1), IM_MAXDIM) + + depth = PL_MAXDEPTH + if (and (IM_PLFLAGS(im), PL_BOOL) != 0) + depth = 1 + call pl_ssize (IM_PL(im), IM_NDIM(im), IM_LEN(im,1), depth) + + } + + call strcpy (Memc[imname], IM_NAME(im), SZ_IMNAME) + IM_ACMODE(im) = sv_acmode + IM_UPDATE(im) = sv_update + IM_PIXOFF(im) = 1 + IM_HGMOFF(im) = NULL + IM_BLIST(im) = NULL + IM_HFD(im) = NULL + + pfd = open ("dev$null", READ_WRITE, BINARY_FILE) + IM_PFD(im) = pfd + + # Execute this even if pixel file has already been opened. + call imsetbuf (IM_PFD(im), im) + + # "Fast i/o" in the conventional sense no IMIO buffering) + # is not permitted for mask images, since IMIO must buffer + # the pixels, which are generated at run time. + + if (IM_FAST(im) == YES) { + IM_PLFLAGS(im) = or (IM_PLFLAGS(im), PL_FAST) + IM_FAST(im) = NO + } + + call sfree (sp) +end diff --git a/sys/imio/iki/fxf/fxfrcard.x b/sys/imio/iki/fxf/fxfrcard.x new file mode 100644 index 00000000..e025283e --- /dev/null +++ b/sys/imio/iki/fxf/fxfrcard.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mii.h> +include "fxf.h" + +# FXF_READ_CARD -- Read a FITS header card. + +int procedure fxf_read_card (fd, ibuf, obuf, ncards) + +int fd #I Input file descriptor +char ibuf[ARB] #I input buffer +char obuf[ARB] #O Output buffer +int ncards #I ncards read so far + +int ip, nchars_read +int read() +errchk read + +begin + # We read one FITS block first, read card from it until 36 + # cards have been processed, where we read again. + + if (mod (ncards, 36) == 0) { + nchars_read = read (fd, ibuf, FITS_BLOCK_CHARS) + if (nchars_read == EOF) + return (EOF) + call miiupk (ibuf, ibuf, FITS_BLOCK_BYTES, MII_BYTE, TY_CHAR) + ip = 1 + } + + call amovc (ibuf[ip], obuf, LEN_CARD) + ip = ip + LEN_CARD + + return (LEN_CARD) +end diff --git a/sys/imio/iki/fxf/fxfrdhdr.x b/sys/imio/iki/fxf/fxfrdhdr.x new file mode 100644 index 00000000..7cfc7855 --- /dev/null +++ b/sys/imio/iki/fxf/fxfrdhdr.x @@ -0,0 +1,176 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include <imio.h> +include <mach.h> +include "fxf.h" + + +# FXF_RHEADER -- Read a FITS header into the image descriptor and the +# internal FITS descriptor. + +procedure fxf_rheader (im, group, acmode) + +pointer im #I image descriptor +int group #I group number to read +int acmode #I access mode + +long pixoff, mtime +pointer sp, fit, lbuf, poff +int compress, devblksz, i, impixtype +bool bfloat, lscale, lzero +bool fxf_fpl_equald() +int strncmp() + +errchk fxf_rfitshdr, realloc, syserr, syserrs + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + fit = IM_KDES(im) + + FIT_MAX(fit) = 0.0 + FIT_MIN(fit) = 0.0 + FIT_MTIME(fit) = 0.0 + FIT_IM(fit) = im + FIT_OBJECT(fit) = EOS + IM_CLSIZE(im) = 0 + + # Read the header unit number 'group', setting the values of the + # reserved fields in the FIT descriptor saving it in the FITS cache. + + call fxf_rfitshdr (im, group, poff) + + IM_MIN(im) = FIT_MIN(fit) + IM_MAX(im) = FIT_MAX(fit) + IM_MTIME(im) = FIT_MTIME(fit) + call strcpy (FIT_OBJECT(fit), IM_TITLE(im), LEN_CARD) + + # If there is no group specification in the filename, group is -1; + # new group number is in FIT_GROUP. + + group = FIT_GROUP(fit) + IM_CLINDEX(im) = group + + # Process the reserved keywords (set in the FIT descriptor) into the + # corresponding fields of the IMIO descriptor. + + if (acmode != NEW_COPY) { + IM_NDIM(im) = FIT_NAXIS(fit) # IM_NDIM + do i = 1, IM_NDIM(im) { # IM_LEN + IM_LEN(im,i) = FIT_LENAXIS(fit,i) + if (IM_LEN(im,i) == 0) { + IM_NDIM(im) = 0 + break + } + } + } + + lscale = fxf_fpl_equald (1.0d0, FIT_BSCALE(fit), 1) + lzero = fxf_fpl_equald (0.0d0, FIT_BZERO(fit), 1) + + # Determine if scaling is necessary. + bfloat = (!lscale || !lzero) + + FIT_PIXTYPE(fit) = NULL + FIT_ZCNV(fit) = NO + + switch (FIT_BITPIX(fit)) { + case 8: + FIT_PIXTYPE(fit) = TY_UBYTE + if (bfloat) + impixtype = TY_REAL + else + impixtype = TY_SHORT # convert from byte to short + FIT_ZCNV(fit) = YES + case 16: + FIT_PIXTYPE(fit) = TY_SHORT + if (bfloat) { + impixtype = TY_REAL + FIT_ZCNV(fit) = YES + } else + impixtype = TY_SHORT + + if ((strncmp ("USHORT", FIT_DATATYPE(fit), 6) == 0) || + (lscale && fxf_fpl_equald (32768.0d0, FIT_BZERO(fit),4))) { + impixtype = TY_USHORT + FIT_ZCNV(fit) = NO + } + case 32: + FIT_PIXTYPE(fit) = TY_INT + if (bfloat) + impixtype = TY_REAL + else + impixtype = TY_INT + case -32: + FIT_PIXTYPE(fit) = TY_REAL + impixtype = TY_REAL + case -64: + FIT_PIXTYPE(fit) = TY_DOUBLE + impixtype = TY_DOUBLE + default: + impixtype = ERR + } + + IM_PIXTYPE(im) = impixtype + + IM_NBPIX(im) = 0 # no. bad pixels + mtime = IM_MTIME(im) + + if (IM_MAX(im) > IM_MIN(im)) + IM_LIMTIME(im) = mtime + 1 # time max/min last updated + else + IM_LIMTIME(im) = mtime - 1 # Invalidate DATA(MIN,MAX) + IM_HISTORY(im) = EOS + + # Call up IMIO to set up the remaining image header fields used to + # define the physical offsets of the pixels in the pixfile. + + compress = YES # do not align image lines on blocks + devblksz = 1 # disable all alignment + + pixoff = Memi[poff+group] + FIT_PIXOFF(fit) = pixoff + call imioff (im, pixoff, compress, devblksz) + + call sfree (sp) +end + + +# FXF_FPL_EQUALD -- Compare 2 double precision quantities up to a precision +# given by a tolerance. + +bool procedure fxf_fpl_equald (x, y, it) + +double x, y #I Input quantities to be compare for equality +int it #I Tolerance factor of 10 to compare the values + +int ex, ey +double x1, x2, normx, normy, tol + +begin + # Check for the obvious first. + if (x == y) + return (true) + + # We can't normalize zero, so handle the zero operand cases first. + # Note that the case 0 equals 0 is handled above. + + if (x == 0.0D0 || y == 0.0D0) + return (false) + + # Normalize operands and do an epsilon compare. + call fp_normd (x, normx, ex) + call fp_normd (y, normy, ey) + + if (ex != ey) + return (false) + else { + tol = EPSILOND * 10.0D0 * it + x1 = 1.0D0 + abs (normx - normy) + x2 = 1.0D0 + tol + return (x1 <= x2) + } +end diff --git a/sys/imio/iki/fxf/fxfrename.x b/sys/imio/iki/fxf/fxfrename.x new file mode 100644 index 00000000..677c02dd --- /dev/null +++ b/sys/imio/iki/fxf/fxfrename.x @@ -0,0 +1,53 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include "fxf.h" + + +# FIT_RENAME -- Rename a fits file. NOTE: There is no prevision at this +# time to rename an extension. + +procedure fxf_rename (kernel, oroot, oextn, nroot, nextn, status) + +int kernel #I IKI kernel +char oroot[ARB] #I old image root name +char oextn[ARB] #I old image extn +char nroot[ARB] #I new image root name +char nextn[ARB] #I old image extn +int status #O status value + +pointer sp +int cindx +pointer ohdr_fname, nhdr_fname +bool streq() + +include "fxfcache.com" + +begin + call smark (sp) + call salloc (ohdr_fname, SZ_PATHNAME, TY_CHAR) + call salloc (nhdr_fname, SZ_PATHNAME, TY_CHAR) + + call fxf_init() + + # Generate filenames. + call iki_mkfname (oroot, oextn, Memc[ohdr_fname], SZ_PATHNAME) + call iki_mkfname (nroot, nextn, Memc[nhdr_fname], SZ_PATHNAME) + + if (!streq (Memc[ohdr_fname], Memc[nhdr_fname])) { + iferr (call rename (Memc[ohdr_fname], Memc[nhdr_fname])) + call erract (EA_WARN) + + # Update the cache with the new name. + do cindx=1, rf_cachesize { + if (rf_fit[cindx] == NULL) + next + # Rename the cached entry. + if (streq (Memc[ohdr_fname], rf_fname[1,cindx])) + call strcpy (Memc[nhdr_fname], rf_fname[1,cindx], SZ_FNAME) + } + } + + status = OK + call sfree (sp) +end diff --git a/sys/imio/iki/fxf/fxfrfits.x b/sys/imio/iki/fxf/fxfrfits.x new file mode 100644 index 00000000..30a8d5f7 --- /dev/null +++ b/sys/imio/iki/fxf/fxfrfits.x @@ -0,0 +1,1322 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <time.h> +include <ctype.h> +include <imhdr.h> +include <imio.h> +include <finfo.h> +include <fset.h> +include <mach.h> +include <imset.h> +include <error.h> +include "fxf.h" + +# FXFRFITS.X -- Routines to load FITS header in memory and set up the cache +# mechanism. + +define LEN_UACARD_100 8100 +define LEN_UACARD_5 405 + + +# FXF_RFITSHDR -- Procedure to read one or more FITS header while caching +# the primary header, set the FITS memory structure for each +# filename, the header and pixel offset from the beginning +# and the EXTNAME and EXTVER value for each extension. + +procedure fxf_rfitshdr (im, group, poff) + +pointer im #I image descriptor +int group #I Group number to read +int poff #O char offset the the pixel area in the FITS image + +long fi[LEN_FINFO] +pointer hoff,totpix, extn, extv +pointer sp, fit, o_fit, lbuf, hdrfile, hdr +int cindx, cfit, user, fitslen, offs_count +int in, spool, slot, i, nrec1440, acmode + +bool initialized, reload, extname_or_ver, ext_append +data initialized /false/ +int rf_refcount + +bool streq() +long cputime(), fstatl() + +int finfo(), open(), stropen(), getline() + +errchk putline, syserrs, seek, calloc, realloc, syserr +errchk fpathname, calloc, fxf_load_header, fxf_skip_xtn, fxf_read_xtn + +include "fxfcache.com" + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + call salloc (hdrfile, SZ_PATHNAME, TY_CHAR) + + # Initialize the header file cache on the first call. The kernel + # doesn't appear to work with the cache completely deactivated, so + # the minimum cachesize is 1. + + if (!initialized) { + rf_refcount = 0 + do i = 1, MAX_CACHE + rf_fit[i] = 0 + rf_cachesize = max(1, min(MAX_CACHE, FKS_CACHESIZE(IM_KDES(im)))) + initialized = true + } else + rf_refcount = rf_refcount + 1 + + o_fit = IM_KDES(im) + reload = false + slot = 1 + # Get file system info on the desired header file. + call fpathname (IM_HDRFILE(im), Memc[hdrfile], SZ_PATHNAME) + + if (finfo (Memc[hdrfile], fi) == ERR) + call syserrs (SYS_FOPEN, IM_HDRFILE(im)) + + acmode = FIT_ACMODE(o_fit) + ext_append = (acmode == NEW_IMAGE || acmode == NEW_COPY) + repeat { + # Search the header file cache for the named image. + do cindx = 1, rf_cachesize { + if (rf_fit[cindx] == NULL) { + slot = cindx + next + } + if (streq (Memc[hdrfile], rf_fname[1,cindx])) { + # File is in cache; is cached entry still valid? + # If we are appending extension, do not reload from + # disk. + + if (FI_MTIME(fi) != rf_mtime[cindx] && !ext_append) { + # File modify date has changed, reuse slot. + slot = cindx + break + } + + # For every non-empty file the fxf_open() call + # pre reads every PHU, so that when the fxf_rdhdr() + # comes, the cache entry is already here. + + # Return the cached header. + rf_lru[cindx] = rf_refcount + cfit = rf_fit[cindx] + FIT_XTENSION(cfit) = FIT_XTENSION(o_fit) + FIT_ACMODE(cfit) = FIT_ACMODE(o_fit) + FIT_EXPAND(cfit) = FIT_EXPAND(o_fit) + + # Load Extend value from cache header entry to + # the current fit struct entry. + + FIT_EXTEND(o_fit) = FIT_EXTEND(cfit) + + call amovi (FIT_ACMODE(cfit), FIT_ACMODE(o_fit), + LEN_FITBASE) + hoff = rf_hdrp[cindx] + poff = rf_pixp[cindx] + extn = rf_pextn[cindx] + extv = rf_pextv[cindx] + FIT_GROUP(o_fit) = group + FIT_HDRPTR(o_fit) = hoff + FIT_PIXPTR(o_fit) = poff + + extname_or_ver = (FKS_EXTNAME(o_fit) != EOS || + !IS_INDEFL (FKS_EXTVER(o_fit))) + + # If the group number or extname_or_ver has not been + # specified we need to load the group number where there + # is data i.e., FIT_NAXIS != 0. The 'cfit' structure would + # have this group number. + + if (group == -1 && !extname_or_ver) { + if (FIT_GROUP(cfit) != -1) { + group = FIT_GROUP(cfit) + FIT_GROUP(o_fit) = group + + } else if (FIT_NAXIS(cfit) != 0) { + # See if the main FITS unit has data when + # group = -1 is specified. + + group = 0 + FIT_GROUP(cfit) = 0 + FIT_GROUP(o_fit) = 0 + } + } + + # The main header has already been read at this point, + # now merge with UA. + + if (group == 0) { + hdr = rf_hdr[cindx] + fitslen = rf_fitslen[cindx] + FIT_EXTEND(o_fit) = FIT_EXTEND(cfit) + call fxf_merge_w_ua (im, hdr, fitslen) + + } else { + # Read intermediate xtension headers if not in + # hoff and poff yet. + offs_count = FIT_NUMOFFS(cfit) + call fxf_read_xtn (im, + cfit, group, hoff, poff, extn, extv) + } + + # IM_CTIME takes the value of the DATE keyword + if (IM_CTIME(im)==0) { + IM_CTIME(im) = FI_CTIME(fi) + } + + # FIT_MTIME takes the value of keyword IRAF-TLM. + # If not present use the mtime from the finfo value. + + if (FIT_MTIME(cfit) == 0) { + FIT_MTIME(cfit) = FI_MTIME(fi) + } + + # Invalidate entry if cache is disabled. + if (rf_cachesize <= 0) + rf_time[cindx] = 0 + + call sfree (sp) + return # IN CACHE + + } else { + # Keep track of least recently used slot. + if (rf_lru[cindx] < rf_lru[slot]) + slot = cindx + } + } + + # Either the image header is not in the cache, or the cached + # entry is invalid. Prepare the given cache slot and read the + # header into it. + + # Free old save buffer and descriptor. + if (rf_fit[slot] != NULL) { + call mfree (rf_pextv[slot], TY_INT) + call mfree (rf_pextn[slot], TY_CHAR) + call mfree (rf_pixp[slot], TY_INT) + call mfree (rf_hdrp[slot], TY_INT) + call mfree (rf_fit[slot], TY_STRUCT) + call mfree (rf_hdr[slot], TY_CHAR) + rf_fit[slot] = NULL + rf_lru[slot] = 0 + rf_fname[1,slot] = EOS + } + + # Allocate a spool file for the FITS data. + spool = open ("spool", NEW_FILE, SPOOL_FILE) + + # Allocate cache version of FITS descriptor. + call calloc (fit, LEN_FITBASE, TY_STRUCT) + call calloc (hoff, MAX_OFFSETS, TY_INT) + call calloc (poff, MAX_OFFSETS, TY_INT) + call calloc (extn, MAX_OFFSETS*LEN_CARD, TY_CHAR) + call calloc (extv, MAX_OFFSETS, TY_INT) + + # Initialize the entries. + call amovki (INDEFL, Memi[extv], MAX_OFFSETS) + call aclrc (Memc[extn], MAX_OFFSETS) + call amovki (-1, Memi[poff], MAX_OFFSETS) + + FIT_GROUP(fit) = -1 + FIT_HDRPTR(fit) = hoff + FIT_PIXPTR(fit) = poff + FIT_NUMOFFS(fit) = MAX_OFFSETS + FIT_ACMODE(fit) = FIT_ACMODE(o_fit) + FIT_BSCALE(fit) = 1.0d0 + FIT_BZERO(fit) = 0.0d0 + FIT_XTENSION(fit) = NO + FIT_EXTNAME(fit) = EOS + FIT_EXTVER(fit) = INDEFL + FIT_EXTEND(fit) = -3 + + # Initialize the cache entry. + call strcpy (Memc[hdrfile], rf_fname[1,slot], SZ_PATHNAME) + rf_fit[slot] = fit + rf_hdrp[slot] = hoff + rf_pixp[slot] = poff + rf_pextn[slot] = extn + rf_pextv[slot] = extv + rf_lru[slot] = rf_refcount + rf_mtime[slot] = FI_MTIME(fi) + + if (!reload) + rf_time[slot] = cputime (0) + + reload = true + + in = IM_HFD(im) + call seek (in, BOFL) + + # Read main FITS header and copy to spool fd. + FIT_IM(fit) = im + call amovki (1, FIT_LENAXIS(fit,1), IM_MAXDIM) + + call fxf_load_header (in, fit, spool, nrec1440, totpix) + + + # Record group 0 (PHU) as having just been read. + FIT_GROUP(fit) = 0 + + call seek (spool, BOFL) + fitslen = fstatl (spool, F_FILESIZE) + + # Prepare cache area to store the FITS header. + call calloc (hdr, fitslen, TY_CHAR) + user = stropen (Memc[hdr], fitslen, NEW_FILE) + rf_hdr[slot] = hdr + rf_fitslen[slot] = fitslen + FIT_CACHEHDR(fit) = hdr + FIT_CACHEHLEN(fit) = fitslen + + # Append the saved FITS cards to saved cache. + while (getline (spool, Memc[lbuf]) != EOF) + call putline (user, Memc[lbuf]) + + call close (user) + call close (spool) + + # Group 0 (i.e. Main Fits unit) + Memi[hoff] = 1 # beginning of primary h.u. + Memi[poff] = nrec1440 + 1 # first pixel data of main u. + + # Set group 1 offsets. + Memi[hoff+1] = Memi[poff] + totpix + Memi[poff+1] = -1 + } + + call sfree (sp) +end + + +# FXF_READ_XTN -- Procedure to read a FITS extension header and at the same +# time make sure that the EXTNAME and EXTVER values are not repeated +# with those in the cache. + +procedure fxf_read_xtn (im, cfit, igroup, hoff, poff, extn, extv) + +pointer im #I Image descriptor +pointer cfit #I Cached FITS descriptor +int igroup #I Group number to process +pointer hoff #I Pointer to header offsets array +pointer poff #I Pointer to pixel offsets array +pointer extn #I Pointer to extname's array +pointer extv #I Pointer to extver's array + +char messg[SZ_LINE] +pointer lfit, sp, po, ln +int spool, ig, acmode, i +int fitslen, xtn_hd, nrec1440, totpix, in, group +int strcmp(), getline() +long offset, fstatl() +int open(), fxf_extnv_error() +bool ext_append, get_group + +errchk fxf_load_header, fxf_skip_xtn, syserr, syserrs +define rxtn_ 91 + +begin + # Allocate a spool file for the FITS header. + spool = open ("FITSHDRX", READ_WRITE, SPOOL_FILE) + + lfit = IM_KDES(im) + group = FIT_GROUP(lfit) + acmode = FIT_ACMODE(lfit) + ext_append = (acmode == NEW_IMAGE || acmode == NEW_COPY) + + # If we have 'overwrite' in the ksection then look for the + # existent extname/extver we want to overwrite since we don't + # want to append. + + if (FKS_OVERWRITE(lfit) == YES) + ext_append = false + + # See if we want to look at an extension given the EXT(NAME,VER) + # field in the ksection. + + if (FKS_EXTNAME(lfit) != EOS || !IS_INDEFL (FKS_EXTVER(lfit))) { + ig = 1 + repeat { + call fseti (spool, F_CANCEL, YES) + xtn_hd = NO + + # Has last extension header been read? + if (Memi[poff+ig] <= 0) { + iferr { + call fxf_skip_xtn (im, + ig, cfit, hoff, poff, extn, extv, spool) + xtn_hd = YES + } then { + if (ext_append) { + # We have reach the end of extensions. + FIT_GROUP(lfit) = -1 # message for fxf_updhdr + return + } else { + call fxf_form_messg (lfit, messg) + call syserrs (SYS_FXFRFNEXTNV, messg) + } + } else { + # If we want to append an extension then. + if (ext_append && FKS_DUPNAME(lfit) == NO) + if (fxf_extnv_error (lfit, ig, extn, extv) == YES) { + call fxf_form_messg (lfit, messg) + call syserrs (SYS_FXFOPEXTNV, messg) + } + } + } + + if (fxf_extnv_error (lfit, ig, extn, extv) == YES) { + # We have matched either or both FKS_EXTNAME and FKS_EXTVER + # with the values in the cache. + + if (ext_append && FKS_DUPNAME(lfit) == NO) { + call fxf_form_messg (lfit, messg) + call syserrs (SYS_FXFOPEXTNV, messg) + } + group = ig + FIT_GROUP(lfit) = ig + goto rxtn_ + + } else { + ig = ig + 1 + next + } + } + + } else { + # No extname or extver specified. + # Read through the Extensions until group number is reached; + # if no number is supplied, read until EOF to load header and + # pixel offsets necessary to append and extension. + + if (igroup == -1 && FIT_GROUP(cfit) == -1) + group = MAX_INT + + # We are trying to get the first group that meets these condition. + get_group = (FIT_GROUP(cfit) == -1 && igroup == -1) + + do ig = 0, group { + xtn_hd = NO + + # Has last extension header been read? + if (Memi[poff+ig] <= 0 ) { + call fseti (spool, F_CANCEL, YES) + iferr { + call fxf_skip_xtn (im, + ig, cfit, hoff, poff, extn, extv, spool) + xtn_hd = YES + } then { + if (ext_append) { + # We have reach the end of extensions. + FIT_GROUP(lfit) = -1 # message for fxf_updhdr + return + } else { + call syserrs (SYS_FXFRFEOF, IM_NAME(im)) + return + } + } + + # Mark the first group that contains an image + # i.e. naxis != 0. + + if (FIT_NAXIS(lfit) != 0 && + strcmp ("IMAGE", FIT_EXTTYPE(lfit)) == 0) { + if (get_group) { + FIT_GROUP(cfit) = ig # save on cache fits struct + FIT_GROUP(lfit) = ig # also on current + break + } else if (FIT_GROUP(cfit) <= 0) + FIT_GROUP(cfit) = ig + } + } + } + } +rxtn_ + if (xtn_hd == NO) { + in = IM_HFD(im) + offset = Memi[hoff+group] + call seek (in, offset) + FIT_IM(lfit) = im + call fseti (spool, F_CANCEL, YES) + call fxf_load_header (in, lfit, spool, nrec1440, totpix) + } + + # If requested a non supported BINTABLE format, post an error + # message and return to the caller. + + if (strcmp(FIT_EXTTYPE(lfit), "BINTABLE") == 0) { + if (strcmp(FIT_EXTSTYPE(lfit), "PLIO_1") != 0) { + call close (spool) + call syserrs (SYS_IKIEXTN, IM_NAME(im)) + } + } + + # Merge Image Extension header to the user area. + fitslen = fstatl (spool, F_FILESIZE) + + # Copy the spool array into a static array. We cannot reliable + # get the pointer from the spool file. + call smark (sp) + call salloc (ln, LEN_UACARD, TY_CHAR) + + if (po != NULL) + call mfree(po, TY_CHAR) + call calloc (po, fitslen+1, TY_CHAR) + + i = po + call seek (spool, BOFL) + while (getline (spool, Memc[ln]) != EOF) { + + call amovc (Memc[ln], Memc[i], LEN_UACARD) + i = i + LEN_UACARD + } + Memc[i] = EOS + + # Make the user aware that they cannot use inheritance + # if the PDU contains a data array. + + if (Memi[poff] != Memi[hoff+1]) { + if (FKS_INHERIT(lfit) == YES) { + call syserr (SYS_FXFBADINH) + } + } else { + # Disable inheritance if PHDU has a DU. + if (Memi[poff+0] != Memi[hoff+1]) + FIT_INHERIT(lfit) = NO + } + + # Reset the value of FIT_INHERIT if FKS_INHERIT is set + if (FKS_INHERIT(lfit) != NO_KEYW) + FIT_INHERIT(lfit) = FKS_INHERIT(lfit) + + if (FIT_TFIELDS(lfit) > 0) { + fitslen = fitslen + FIT_TFIELDS(lfit)*LEN_UACARD + call realloc (po, fitslen, TY_CHAR) + } + + call fxf_merge_w_ua (im, po, fitslen) + + call mfree (po, TY_CHAR) + + call sfree (sp) + call close (spool) +end + + +# FXF_EXTNV_ERROR -- Integer boolean function (YES,NO) to find out if the +# value of kernel section parameter FKS_EXTNAME and FKS_EXTVER are not +# repeated in the cache pointed by extn and extv. + +int procedure fxf_extnv_error (fit, ig, extn, extv) + +pointer fit #I fit descriptor +int ig #I extension number +pointer extn, extv #I pointers to arrays for extname and extver + +bool bxtn, bxtv, bval, bxtn_eq, bxtv_eq +int fxf_strcmp_lwr() + +begin + bxtn = (FKS_EXTNAME(fit) != EOS) + bxtv = (!IS_INDEFL (FKS_EXTVER(fit))) + + if (bxtn) + bxtn_eq = + (fxf_strcmp_lwr(FKS_EXTNAME(fit), Memc[extn+LEN_CARD*ig]) == 0) + if (bxtv) + bxtv_eq = (FKS_EXTVER(fit) == Memi[extv+ig]) + + if (bxtn && bxtv) { + # Since both FKS_EXTNAME and FKS_EXTVER are defined, see if they + # repeated in the cache. + + bval = (bxtn_eq && bxtv_eq) + + } else if (bxtn && !bxtv) { + # We have a duplicated in this case when extver in the image + # header is INDEFL. + + bval = bxtn_eq + + } else if (!bxtn && bxtv) { + # If the FKS_EXTNAME is not defined (i.e. EOS) and the FKS_EXTVER + # value is the same as the cached, then we have a match. + + bval = bxtv_eq + + } else + bval = false + + if (bval) + return (YES) + else + return (NO) +end + + +# FXF_SKIP_XTN -- Skip over a FITS extension. The procedure will read the +# current extension header and calculates the respectives offset for later +# usage. + +procedure fxf_skip_xtn (im, group, cfit, hoff, poff, extn, extv, spool) + +pointer im #I image descriptor +int group #I groupheader number to read +pointer cfit #I cached fits descriptor +pointer hoff #I extension header offset +pointer poff #I extension data offset +pointer extn #I points to the array of extname +pointer extv #I points to the arrays of extver + +pointer sp, lfit, fit, hdrfile +bool streq() +int spool, in, nrec1440, totpix, i, k, cindx +long offset +errchk fxf_load_header +int strcmp() + +include "fxfcache.com" + +begin + call smark (sp) + call salloc (lfit, LEN_FITBASE, TY_STRUCT) + call salloc (hdrfile, SZ_PATHNAME, TY_CHAR) + + call seek (spool, BOFL) + fit = IM_KDES(im) + + # Allocate more memory for offsets in case we are pass MAX_OFFSETS. + if (group >= FIT_NUMOFFS(cfit)) { + FIT_NUMOFFS(cfit) = FIT_NUMOFFS(cfit) + MAX_OFFSETS + call realloc (hoff, FIT_NUMOFFS(cfit), TY_INT) + call realloc (poff, FIT_NUMOFFS(cfit), TY_INT) + call realloc (extn, FIT_NUMOFFS(cfit)*LEN_CARD, TY_CHAR) + call realloc (extv, FIT_NUMOFFS(cfit), TY_INT) + + offset = FIT_NUMOFFS(cfit) - MAX_OFFSETS + call amovki (INDEFL, Memi[extv+offset], MAX_OFFSETS) + call amovki (-1, Memi[poff+offset], MAX_OFFSETS) + + do i = 0, MAX_OFFSETS-1 { + k = (offset+i)*LEN_CARD + Memc[extn+k] = EOS + } + + # Update the fits structure with the new pointer values + call fpathname (IM_HDRFILE(im), Memc[hdrfile], SZ_PATHNAME) + fit = IM_KDES(im) + do cindx = 1, rf_cachesize { + if (rf_fit[cindx] == NULL) + next + if (streq (Memc[hdrfile], rf_fname[1,cindx])) { + rf_pextn[cindx] = extn + rf_pextv[cindx] = extv + rf_hdrp[cindx] = hoff + rf_pixp[cindx] = poff + FIT_HDRPTR(fit) = hoff + FIT_PIXPTR(fit) = poff + } + } + } + + in = IM_HFD(im) + offset = Memi[hoff+group] + + call seek (in, offset) + lfit = IM_KDES(im) + FIT_IM(lfit) = im + call fxf_load_header (in, lfit, spool, nrec1440, totpix) + + # Record the first group that has NAXIS !=0 and is an IMAGE. + if (FIT_GROUP(cfit) == -1) { + if (FIT_NAXIS(lfit) != 0 && + strcmp ("IMAGE", FIT_EXTTYPE(lfit)) == 0) + FIT_GROUP(cfit) = group + } + + Memi[poff+group] = Memi[hoff+group] + nrec1440 + # The offset for the beginning of next group. + Memi[hoff+group+1] = Memi[poff+group] + totpix + + # Mark next group pixel offset in case we are at EOF. + Memi[poff+group+1] = -1 + call strcpy (FIT_EXTNAME(lfit), Memc[extn+LEN_CARD*group], LEN_CARD) + Memi[extv+group] = FIT_EXTVER(lfit) + + call sfree (sp) +end + + +# FXF_LOAD_HEADER -- Load a FITS header from a file descriptor into a +# spool file. + +procedure fxf_load_header (in, fit, spool, nrec1440, datalen) + +int in #I input FITS header file descriptor +pointer fit #I FITS descriptor +int spool #I spool output file descriptor +int nrec1440 #O number of 1440 char records output +int datalen #O length of data area in chars + +int ncols +pointer lbuf, sp, im, stime, fb, ttp +int totpix, nchars, nbytes, index, ncards, simple, i, pcount, junk +int fxf_read_card(), fxf_ctype(), ctoi(), strsearch() +bool fxf_fpl_equald() +errchk syserr, syserrs + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + call salloc (stime, LEN_CARD, TY_CHAR) + call salloc (fb, FITS_BLOCK_BYTES, TY_CHAR) + + FIT_BSCALE(fit) = 1.0d0 + FIT_BZERO(fit) = 0.0d0 + FIT_EXTNAME(fit) = EOS + FIT_EXTVER(fit) = INDEFL + im = FIT_IM(fit) + + # Read successive lines of the FITS header. + nrec1440 = 0 + pcount = 0 + ncards = 0 + + repeat { + # Get the next input line. + nchars = fxf_read_card (in, Memc[fb], Memc[lbuf], ncards) + if (nchars == EOF) { + call close (spool) + call syserrs (SYS_FXFRFEOF, IM_NAME(im)) + } + ncards = ncards + 1 + + # A FITS header card already has 80 chars, just add the newline. + Memc[lbuf+LEN_CARD] = '\n' + Memc[lbuf+LEN_CARD+1] = EOS + + # Process the header card. + switch (fxf_ctype (Memc[lbuf], index)) { + case KW_END: + nrec1440 = FITS_LEN_CHAR(ncards*40) + break + case KW_SIMPLE: + call strcpy ("SIMPLE", FIT_EXTTYPE(fit), SZ_EXTTYPE) + call fxf_getb (Memc[lbuf], simple) + FIT_EXTEND(fit) = NO_KEYW + if (simple == NO) + call syserr (SYS_FXFRFSIMPLE) + case KW_EXTEND: + call putline (spool, Memc[lbuf]) + call fxf_getb (Memc[lbuf], FIT_EXTEND(fit)) + case KW_XTENSION: + FIT_XTENSION(fit) = YES + call fxf_gstr (Memc[lbuf], FIT_EXTTYPE(fit), SZ_EXTTYPE) + case KW_EXTNAME: + call fxf_gstr (Memc[lbuf], FIT_EXTNAME(fit), LEN_CARD) + call putline (spool, Memc[lbuf]) + case KW_EXTVER: + call fxf_geti (Memc[lbuf], FIT_EXTVER(fit)) + call putline (spool, Memc[lbuf]) + case KW_ZCMPTYPE: + call fxf_gstr (Memc[lbuf], FIT_EXTSTYPE(fit), SZ_EXTTYPE) + case KW_PCOUNT: + call fxf_geti (Memc[lbuf], pcount) + call putline (spool, Memc[lbuf]) + FIT_PCOUNT(fit) = pcount + case KW_INHERIT: + call fxf_getb (Memc[lbuf], FIT_INHERIT(fit)) + call putline (spool, Memc[lbuf]) + case KW_BITPIX: + call fxf_geti (Memc[lbuf], FIT_BITPIX(fit)) + case KW_DATATYPE: + call fxf_gstr (Memc[lbuf], FIT_DATATYPE(fit), SZ_DATATYPE) + case KW_NAXIS: + if (index == 0) { + call fxf_geti (Memc[lbuf], FIT_NAXIS(fit)) + if (FIT_NAXIS(fit) < 0 ) + call syserr (SYS_FXFRFBNAXIS) + } else + call fxf_geti (Memc[lbuf], FIT_LENAXIS(fit,index)) + case KW_BSCALE: + call fxf_getd (Memc[lbuf], FIT_BSCALE(fit)) + # If BSCALE is like 1.00000011 reset to 1.0. + if (fxf_fpl_equald (1.0d0, FIT_BSCALE(fit), 4)) + FIT_BSCALE(fit) = 1.0d0 + call putline (spool, Memc[lbuf]) + case KW_BZERO: + call fxf_getd (Memc[lbuf], FIT_BZERO(fit)) + # If BZERO is like 0.00000011 reset to 0.0. + if (fxf_fpl_equald (0.0d0, FIT_BZERO(fit), 4)) + FIT_BZERO(fit) = 0.0d0 + call putline (spool, Memc[lbuf]) + case KW_DATAMAX: + call fxf_getr (Memc[lbuf], FIT_MAX(fit)) + call putline (spool, Memc[lbuf]) + case KW_DATAMIN: + call fxf_getr (Memc[lbuf], FIT_MIN(fit)) + call putline (spool, Memc[lbuf]) + case KW_TFIELDS: + # Allocate space for TFORM and TTYPE keyword values + call fxf_geti (Memc[lbuf], ncols) + FIT_TFIELDS(fit) = ncols + if (FIT_TFORMP(fit) != NULL) { + call mfree (FIT_TFORMP(fit), TY_CHAR) + call mfree (FIT_TTYPEP(fit), TY_CHAR) + } + call calloc (FIT_TFORMP(fit), ncols*LEN_FORMAT, TY_CHAR) + call calloc (FIT_TTYPEP(fit), ncols*LEN_OBJECT, TY_CHAR) + case KW_TFORM: + call fxf_gstr (Memc[lbuf], Memc[stime], LEN_CARD) + if (index == 1) { + # PLMAXLEN is used to indicate the maximum line list + # length for PLIO masks in bintables. The syntax + # "PI(maxlen)" is used in bintables to pass the max + # vararray length for a column. + + i = strsearch (Memc[stime], "PI(") + if (i > 0) + junk = ctoi (Memc[stime], i, FIT_PLMAXLEN(fit)) + } + case KW_TTYPE: + ttp = FIT_TTYPEP(fit) + (index-1)*LEN_OBJECT + call fxf_gstr (Memc[lbuf], Memc[ttp], LEN_CARD) + case KW_OBJECT: + # Since only OBJECT can go into the header and IM_TITLE has its + # values as well, we need to save both to see which one has + # changed at closing time. + + call fxf_gstr (Memc[lbuf], FIT_OBJECT(fit), LEN_CARD) + if (FIT_OBJECT(fit) == EOS) + call strcpy (" ", FIT_OBJECT(fit), SZ_KEYWORD) + call strcpy (FIT_OBJECT(fit), FIT_TITLE(fit), LEN_CARD) + call strcpy (FIT_OBJECT(fit), IM_TITLE(im), LEN_CARD) + call putline (spool, Memc[lbuf]) + case KW_IRAFTLM: + call fxf_gstr (Memc[lbuf], Memc[stime], LEN_CARD) + call fxf_date2limtime (Memc[stime], FIT_MTIME(fit)) + call putline (spool, Memc[lbuf]) + case KW_DATE: + call fxf_gstr (Memc[lbuf], Memc[stime], LEN_CARD) + call fxf_date2limtime (Memc[stime], IM_CTIME(im)) + call putline (spool, Memc[lbuf]) + default: + call putline (spool, Memc[lbuf]) + } + } + + # Calculate the length of the data area of the current extension, + # measured in SPP chars and rounded up to an integral number of FITS + # logical blocks. + + if (FIT_NAXIS(fit) != 0) { + totpix = FIT_LENAXIS(fit,1) + do i = 2, FIT_NAXIS(fit) + totpix = totpix * FIT_LENAXIS(fit,i) + + # Compute the size of the data area (pixel matrix plus PCOUNT) + # in bytes. Be careful not to overflow a 32 bit integer. + + nbytes = (totpix + pcount) * (abs(FIT_BITPIX(fit)) / NBITS_BYTE) + + # Round up to fill the final 2880 byte FITS logical block. + nbytes = ((nbytes + 2880-1) / 2880) * 2880 + + datalen = nbytes / SZB_CHAR + + } else + datalen = 0 + + call sfree (sp) +end + + +# FXF_MERGE_W_UA -- Merge a spool user area with the im_userarea. + +procedure fxf_merge_w_ua (im, userh, fitslen) + +pointer im #I image descriptor +int userh #I pointer to user area spool +int fitslen #I length in chars of the user area + +bool inherit +pointer sp, lbuf, ua, ln +int elen, elines, nbl, i, k +int sz_userarea, merge, len_hdrmem, fit, clines, ulines +bool fxf_is_blank() +int strlen() + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + call salloc (ln, LEN_UACARD, TY_CHAR) + + fit = IM_KDES(im) + + # FIT_INHERIT has the logically combined value of the fkinit inherit's + # value, if any; the ksection value, if any and the INHERIT value in + # the extension header. + + inherit = (FIT_INHERIT(fit) == YES) + inherit = (inherit && (FIT_GROUP(fit) != 0)) + + # Reallocate the image descriptor to allow space for the spooled user + # FITS cards plus a little extra for new parameters. + + sz_userarea = fitslen + SZ_EXTRASPACE + # Add size of main header if necessary. + if (inherit) + sz_userarea = sz_userarea + FIT_CACHEHLEN(fit) + + IM_HDRLEN(im) = LEN_IMHDR + + (sz_userarea - SZ_EXTRASPACE + SZ_MII_INT-1) / SZ_MII_INT + len_hdrmem = LEN_IMHDR + + (sz_userarea+1 + SZ_MII_INT-1) / SZ_MII_INT + + if (IM_LENHDRMEM(im) < len_hdrmem) { + IM_LENHDRMEM(im) = len_hdrmem + call realloc (im, IM_LENHDRMEM(im) + LEN_IMDES, TY_STRUCT) + } + + + # Copy the extension header to the USERAREA if not inherit or copy + # the global header plus the extension header if inherit is set. + + if (fitslen > 0) { + ua = IM_USERAREA(im) + elen = fitslen + + if (inherit) { + # First, copy those cards in the global header that + # are not in the current extension header. + + clines = strlen (Memc[FIT_CACHEHDR(fit)]) + ulines = strlen (Memc[userh]) + clines = clines / LEN_UACARD + ulines = ulines / LEN_UACARD + merge = YES + call fxf_match_str (FIT_CACHEHDR(fit), + clines, userh, ulines, merge, ua) + elen = LEN_UACARD * ulines + } + + # Append the extension header to the UA. + elines = elen / LEN_UACARD + k = userh + nbl = 0 + + do i = 1, elines { + call strcpy (Memc[k], Memc[ln], LEN_UACARD) + if (fxf_is_blank (Memc[ln])) + nbl = nbl + 1 + else { + # If there are blank cards, add them. + if (nbl > 0) + call fxf_blank_lines (nbl, ua) + call amovc (Memc[ln], Memc[ua], LEN_UACARD) + ua = ua + LEN_UACARD + } + k = k + LEN_UACARD + } + + Memc[ua] = EOS + } + call sfree (sp) +end + + +# FXF_STRCMP_LWR -- Compare 2 strings in lower case mode. + +int procedure fxf_strcmp_lwr (s1, s2) + +char s1[ARB], s2[ARB] #I strings to be compare for equality + +int istat +pointer sp, l1, l2 +int strcmp() + +begin + call smark (sp) + call salloc (l1, LEN_CARD, TY_CHAR) + call salloc (l2, LEN_CARD, TY_CHAR) + + call strcpy (s1, Memc[l1], LEN_CARD) + call strcpy (s2, Memc[l2], LEN_CARD) + call strlwr(Memc[l1]) + call strlwr(Memc[l2]) + istat = strcmp (Memc[l1], Memc[l2]) + + call sfree (sp) + return (istat) +end + + +# FXF_DATE2LIMTIME -- Convert the IRAF_TLM string (used to record the IMIO +# time of last modification of the image) into a long integer limtime +# compatible with routine cnvtime(). The year must be 1980 or later. +# The input date string has one of the following forms: +# +# Old format: "hh:mm:ss (dd/mm/yyyy)" +# New (Y2K/ISO) format: "YYYY-MM-DDThh:mm:ss + +procedure fxf_date2limtime (datestr, limtime) + +char datestr[ARB] #I fixed format date string +long limtime #O output limtime (LST seconds from 1980.0) + +double dsec +int hours,minutes,seconds,day,month,year +int status, iso, flags, ip, m, d, y +int dtm_decode_hms(), btoi(), ctoi() +long gmttolst() +double jd + +begin + iso = btoi (datestr[3] != ':') + status = OK + + if (iso == YES) { + status = dtm_decode_hms (datestr, + year,month,day, hours,minutes,dsec, flags) + + # If the decoded date string is old style FITS then the HMS + # values are indefinite, and we need to set them to zero. + + if (and(flags,TF_OLDFITS) != 0) { + hours = 0 + minutes = 0 + seconds = 0 + } else { + if (IS_INDEFD(dsec)) { + hours = 0 + minutes = 0 + seconds = 0 + } else + seconds = nint(dsec) + } + } else { + ip = 1; ip = ctoi (datestr, ip, hours) + ip = 1; ip = ctoi (datestr[4], ip, minutes) + ip = 1; ip = ctoi (datestr[7], ip, seconds) + ip = 1; ip = ctoi (datestr[11], ip, day) + ip = 1; ip = ctoi (datestr[14], ip, month) + ip = 1; ip = ctoi (datestr[17], ip, year) + } + + if (status == ERR || year < 1980) { + limtime = 0 + return + } + + seconds = seconds + minutes * 60 + hours * 3600 + + # Calculate the Julian day from jan 1, 1980. Algorithm taken + # from astutil/asttools/asttimes.x. + + y = year + if (month > 2) + m = month + 1 + else { + m = month + 13 + y = y - 1 + } + + # Original: jd = int (JYEAR * y) + int (30.6001 * m) + day + 1720995 + # -723244.5 is the number of days to add to get 'jd' from jan 1, 1980. + + jd = int (365.25 * y) + int (30.6001 * m) + day - 723244.5 + if (day + 31 * (m + 12 * y) >= 588829) { + d = int (y / 100) + m = int (y / 400) + jd = jd + 2 - d + m + } + jd = jd - 0.5 + day = jd + + limtime = seconds + day * 86400 + if (iso == YES) + limtime = gmttolst (limtime) +end + + +# FIT_MATCH_STR -- FITS header pattern matching algorithm. Match mostly one +# line of lenght LEN_UACARD with the buffer pointed by str; if pattern is not +# in str, put it in the 'out' buffer. + +procedure fxf_match_str (pat, plines, str, slines, merge, po) + +pointer pat #I buffer with pattern +int plines #I number of pattern +pointer str #I string to compare the pattern with +int slines #I number of lines in str +int merge #I flag to indicate merging or unmerge +pointer po #I matching pattern accumulation pointer + +char line[LEN_UACARD] +pointer sp, pt, tpt, tst, ps, pkp +int nbl, l, k, j, i, strncmp(), nbkw, nsb, cmplen +int stridxs() + +begin + call smark (sp) + call salloc (tpt, LEN_UACARD_100+1, TY_CHAR) + call salloc (tst, LEN_UACARD_5+1, TY_CHAR) + + Memc[tpt] = EOS + Memc[tst] = EOS + + # The temporary buffer is non blank only when it has a blank + # keyword following by a comentary: + + #1) ' ' / Comment to the block of keyw + #2) KEYWORD = Value + + nbl = 0 + nbkw = 0 + pt = pat - LEN_UACARD + + for (k=1; k <= plines; k=k+1) { + pt = pt + LEN_UACARD + call strcpy (Memc[pt], line, LEN_UACARD) + + # Do not pass these keywords if merging. + if (merge == YES) { + if (strncmp (line, "COMMENT ", 8) == 0 || + strncmp (line, "HISTORY ", 8) == 0 || + strncmp (line, "OBJECT ", 8) == 0 || + strncmp (line, "EXTEND ", 8) == 0 || + strncmp (line, "ORIGIN ", 8) == 0 || + strncmp (line, "IRAF-TLM", 8) == 0 || + strncmp (line, "DATE ", 8) == 0 ) { + + next + } + } + if (line[1] == ' ') { + call fxf_accum_bufp (line, tpt, nbkw, nbl) + next + } + + if (Memc[tpt] != EOS) { + nbkw = nbkw + 1 + call strcat (line, Memc[tpt], LEN_UACARD_100) + Memc[tst] = EOS + + # Now that we have a buffer with upto 100 lines, we take its + # last 5 card and we are going to compare it with upto 5 + # lines (that can contain blank lines in between). + + pkp = tpt + LEN_UACARD*(nbkw-1) + ps = str - LEN_UACARD + nsb = 0 + + do j = 1, slines { + ps = ps + LEN_UACARD + call strcpy (Memc[ps], line, LEN_UACARD) + + if (line[1] == ' ') { + call fxf_accum_buft (line, tst, nsb) + next + + } else if (Memc[tst] != EOS) { + nsb = nsb + 1 + call strcat (line, Memc[tst], LEN_UACARD_5) + + # To begin compare the first character in the + # keyword line. + + if (Memc[pkp] == line[1]) { + if (strncmp (Memc[pkp-LEN_UACARD*(nsb-1)], + Memc[tst], LEN_UACARD*nsb) == 0) { + nsb = 0 + break + } + } + + nsb = 0 + Memc[tst] = EOS + } + } + + if (j == slines+1) { + if (nbl > 0) + call fxf_blank_lines (nbl, po) + i = tpt + do l = 1, min(100, nbkw) { + call amovc (Memc[i], Memc[po], LEN_UACARD) + i = i + LEN_UACARD + po = po + LEN_UACARD + } + } else { + pt = pt - LEN_UACARD # push back last line + k = k - 1 + } + + Memc[tpt] = EOS + nbkw = 0 + nbl = 0 + + } else { + # One line to compare. + ps = str - LEN_UACARD + cmplen = min (stridxs("=", Memc[pt]), LEN_UACARD) + if (cmplen == 0) + cmplen = LEN_UACARD + +# if (merge == YES) +# cmplen = SZ_KEYWORD + + do j = 1, slines { + ps = ps + LEN_UACARD + if (Memc[ps] == Memc[pt]) { + if (merge == NO) + cmplen = LEN_CARD + if (strncmp (Memc[ps], Memc[pt], cmplen) == 0) { + nbl = 0 + break + } + } + } + + if (j == slines+1) { + if (nbl > 0) + call fxf_blank_lines (nbl, po) + + call amovc (line, Memc[po], LEN_UACARD) + po = po + LEN_UACARD + nbl = 0 + } + } + } + + call sfree (sp) +end + + +# FXF_ACCUM_BUFP -- Accumulate blank keyword cards (No keyword and a / card +# only) and the blank lines in between. + +procedure fxf_accum_bufp (line, tpt, nbkw, nbl) + +char line[LEN_UACARD] #I input card from the pattern buffer +pointer tpt #I pointer to the buffer +int nbkw #U number of blank keyword card +int nbl #U number of blank card before the 1st bkw + +char keyw[SZ_KEYWORD] +bool fxf_is_blank() + +begin + call strcpy (line, keyw, SZ_KEYWORD) + + if (fxf_is_blank (line)) { + # Accumulate blank cards in between bkw cards. + if (nbkw > 0 && nbkw < 100) { + call strcat (line, Memc[tpt], LEN_UACARD_100) + nbkw = nbkw + 1 + } else if (nbkw >= 100) { + nbkw = nbkw - 1 + } else + nbl = nbl + 1 + + } else if (fxf_is_blank (keyw)) { + nbkw = nbkw + 1 + + # We have a blank keyword, but the card is not blank, maybe it is + # a '/ comment' card. Start accumulating upto 100 blank kwy lines. + + if (nbkw < 100) + call strcat (line, Memc[tpt], LEN_UACARD_100) + else + nbkw = nbkw - 1 + } +end + + +# FXF_ACCUM_BUFT -- Accumulate blank keyword keeping track of the blank cards. + +procedure fxf_accum_buft (line, tst, nsb) + +char line[LEN_UACARD] #I input card from the target buffer +pointer tst #I pointer to output buffer +int nsb #U number of consecutives blank cards + +char keyw[SZ_KEYWORD] +bool fxf_is_blank() + +begin + call strcpy (line, keyw, SZ_KEYWORD) + + if (fxf_is_blank (line)) { + if (nsb > 0 && nsb < 5) { + call strcat (line, Memc[tst], LEN_UACARD_5) + nsb = nsb + 1 + } else if (nsb > 4) + nsb = nsb - 1 + } else if (fxf_is_blank (keyw)) { + # We want to pick the last blank kwy only. + call strcpy (line, Memc[tst], LEN_UACARD_5) + nsb = 1 + } +end + + +# FXF_BLANK_LINES -- Write a number of blank lines into output buffer. + +procedure fxf_blank_lines (nbl, po) + +int nbl #U number of blank lines to write +pointer po #I output buffer pointer + +char blk[1] +int i + +begin + blk[1] = ' ' + do i = 1, nbl { + call amovkc (blk[1], Memc[po], LEN_UACARD) + po = po + LEN_UACARD + Memc[po-1] = '\n' + } + nbl = 0 +end + + +# FXF_IS_BLANK -- Determine is the string is blank. + +bool procedure fxf_is_blank (line) + +char line[ARB] #I input string +int i + +begin + for (i=1; IS_WHITE(line[i]); i=i+1) + ; + + if (line[i] == NULL || line[i] == '\n') + return (true) + else + return (false) +end + + +# FXF_FORM_MESSG -- Form string from extname, extver. + +procedure fxf_form_messg (fit, messg) + +pointer fit #I fits descriptor +char messg[ARB] #O string + +begin + if (!IS_INDEFL (FKS_EXTVER(fit))) { + call sprintf (messg, LEN_CARD, "'%s,%d'") + call pargstr (FKS_EXTNAME(fit)) + call pargi (FKS_EXTVER(fit)) + } else { + call sprintf (messg, LEN_CARD, "'%s'") + call pargstr (FKS_EXTNAME(fit)) + } +end diff --git a/sys/imio/iki/fxf/fxfupdhdr.x b/sys/imio/iki/fxf/fxfupdhdr.x new file mode 100644 index 00000000..40a24763 --- /dev/null +++ b/sys/imio/iki/fxf/fxfupdhdr.x @@ -0,0 +1,1478 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <error.h> +include <imhdr.h> +include <imio.h> +include <finfo.h> +include <fio.h> +include <fset.h> +include <mii.h> +include <time.h> +include <mach.h> +include "fxf.h" + +# FXFUPDHDR.X -- Routines to update the header of an image extension on +# disk. + +define SZ_DATESTR 24 + + +# FXF_UPDHDR -- Update the FITS header file. This is done by writing an +# entire new header file and then replacing the old header file with the +# new one. This is necessary since the header file is a text file and text +# files cannot be randomly updated. + +procedure fxf_updhdr (im, status) + +pointer im #I image descriptor +int status #O return status + +pointer sp, fit, mii, poff +pointer outname, fits_file, tmp1, tmp2 +bool adjust_header, overwrite, append +int i, nchars_ua, hdr_fd, group, hdr_off, size +int npad, nlines, pixoff, grp_pix_off, nbks +int acmode, in_fd, diff, hdr_acmode, in_off, nchars, subtype +int read(), fxf_hdr_offset(), access(), strncmp() +int open(), fstatl(), fnldir(), strlen(), stridxs() +bool fnullfile() + +errchk open, read, write, fxf_header_diff, fxf_write_header, fxf_make_adj_copy +errchk fxf_set_cache_time, syserr, syserrs, imerr +errchk fxf_expandh, fxf_not_incache, fxf_ren_tmp, fxf_update_extend +long clktime() + +begin + call smark (sp) + call salloc (mii, FITS_BLOCK_CHARS, TY_INT) + call salloc (fits_file, SZ_FNAME, TY_CHAR) + call salloc (outname, SZ_PATHNAME, TY_CHAR) + call salloc (tmp1, max(SZ_PATHNAME,SZ_FNAME*2), TY_CHAR) + call salloc (tmp2, max(SZ_PATHNAME,SZ_FNAME*2), TY_CHAR) + + acmode = IM_ACMODE(im) + fit = IM_KDES(im) + status = OK + + # For all intents and purposes the APPEND access mode is the same + # as NEW_IMAGE under the FK. Let's simplify the code as the user + # has requested APPEND. + + if (acmode == APPEND) + acmode = NEW_IMAGE + + if (acmode == READ_ONLY) + call imerr (IM_NAME(im), SYS_IMUPIMHDR) + + if (fnullfile (IM_HDRFILE(im))) { + call sfree (sp) + return + } + + group = FIT_GROUP(fit) + + subtype = 0 + if ((FKS_SUBTYPE(fit) == FK_PLIO || + (strncmp("PLIO_1", FIT_EXTSTYPE(fit), 6) == 0)) && + (IM_PL(im) != NULL)) + subtype = FK_PLIO + + if (FIT_EXTTYPE(fit) != EOS && group != -1) { + if (strncmp (FIT_EXTTYPE(fit), "IMAGE", 5) != 0 && + strncmp (FIT_EXTTYPE(fit), "SIMPLE", 6) != 0 && + subtype == 0) { + call syserr (SYS_FXFUPHBEXTN) + } + } + + if (FKS_OVERWRITE(fit) == YES) { + if (group == 0) { + # We are overwriting the main unit. + FIT_NEWIMAGE(fit) = YES + } + + group = -1 + acmode = NEW_IMAGE + + if (IM_PFD(im) == NULL) + call fxf_overwrite_unit (fit, im) + + call strcpy (IM_PIXFILE(im), Memc[fits_file], SZ_FNAME) + + } else + call strcpy (IM_HDRFILE(im), Memc[fits_file], SZ_FNAME) + + # Calculate the header offset corresponding to group number 'group'. + FIT_IM(fit) = im + hdr_off = fxf_hdr_offset (group, fit, IM_PFD(im), acmode) + + # If the pixfile has not been created, open new one. This could + # happen if the don't write any pixels to the data portion of the file. + + if (IM_PFD(im) == NULL && (acmode == NEW_COPY || acmode == NEW_IMAGE)) { + FIT_NAXIS(fit) = 0 + if (FIT_NEWIMAGE(fit) == YES) + hdr_acmode = NEW_FILE + else { + # We want to append a new extension with no data. + hdr_acmode = READ_WRITE + } + } else { + call close(IM_PFD(im)) + hdr_acmode = READ_WRITE + } + + append = (acmode == NEW_IMAGE || acmode == NEW_COPY) + + # Calculate header difference. The difference between the original + # header length at open time and now. The user could have added or + # deleted header keywords. + + call fxf_header_diff (im, group, acmode, hdr_off, diff, nchars_ua) + + # PLIO + if (subtype == FK_PLIO && append) + diff = 0 + + # Adjust header only when we need to expand. We fill with trailing + # blanks in case diff .gt. 0. (Reduce header size). + + adjust_header = (diff < 0) + if (adjust_header && FIT_EXPAND(fit) == NO) { + call syserr (SYS_FXFUPHEXP) + adjust_header = false + } + + overwrite = (FKS_OVERWRITE(fit) == YES) + if (adjust_header || overwrite) { + # We need to change the size of header portion in the middle of + # the file. The best thing to do is to make a copy in the output + # filename directory. + + i = strlen (IM_PIXFILE(im)) + nchars = fnldir (IM_PIXFILE(im), Memc[outname], SZ_PATHNAME) + if (nchars > 80 && i > 100) { + i = stridxs ("!", Memc[outname]) + call strcpy ("tmp$", Memc[outname+i], SZ_PATHNAME-i) + } + call strcpy (Memc[outname], Memc[tmp2], SZ_FNAME) + call mktemp ("fx", Memc[tmp1], SZ_PATHNAME) + call strcat (".fits", Memc[tmp1], SZ_PATHNAME) + call strcat ("A", Memc[outname], SZ_PATHNAME) + call strcat (Memc[tmp1], Memc[outname], SZ_PATHNAME) + call strcat ("B", Memc[tmp2], SZ_PATHNAME) + call strcat (Memc[tmp1], Memc[tmp2], SZ_PATHNAME) + in_fd = open (Memc[fits_file], READ_ONLY, BINARY_FILE) + if (access (Memc[outname], 0, 0) == YES) + call delete (Memc[outname]) + hdr_fd = open (Memc[outname], NEW_FILE, BINARY_FILE) + + # Now expand the current group at least one block of 36 cards + # and guarantee that the other groups in the file will have at + # least 'nlines' of blank cards at the end of the header unit. + + nlines= FKS_PADLINES(fit) + IM_HFD(im) = in_fd + + if (adjust_header && acmode != NEW_COPY && + FIT_XTENSION(fit) == YES) { + nbks = -diff/1440 # number of blocks to expand + call fxf_expandh (in_fd, hdr_fd, nlines, group, nbks, + hdr_off, pixoff) + nchars_ua = pixoff - hdr_off + # Reload PHU from file if necessary + call fxf_not_incache(im) + poff = FIT_PIXPTR(fit) + Memi[poff+group] = pixoff + } else { + if (append) + grp_pix_off = FIT_PIXOFF(fit) + else { + # Reload PHU from file if necessary + call fxf_not_incache(im) + grp_pix_off = Memi[FIT_PIXPTR(fit)+group] + } + call fxf_make_adj_copy (in_fd, hdr_fd, + hdr_off, grp_pix_off, nchars_ua) + } + diff = 0 + group = -1 + + # Reset the time so we can read a fresh header next time. + call fxf_set_cache_time (im, overwrite) + } else { + hdr_fd = open (Memc[fits_file], hdr_acmode, BINARY_FILE) + # Do not clear if we are creating a Bintable with type PLIO_1. + if (subtype != FK_PLIO) + IM_PFD(im) = NULL + IM_HFD(im) = NULL + } + + if (FIT_NEWIMAGE(fit) == YES) + call seek (hdr_fd, BOF) + else if (hdr_off != 0) + call seek (hdr_fd, hdr_off) + + if (acmode == NEW_COPY) + call fxf_setbitpix (im, fit) + + # Lets changed the value of FIT_MTIME that will be used as the mtime for + # this updated file. This time them will be different in other + # executable's FITS cache, hence rereading the PHU. + # We need to use FIT_MTIME since it reflec the value of keyword + # IRAF_TLM which could have just recently been modified, hence adding + # the 4 seconds. + + if (abs(FIT_MTIME(fit) - clktime(long(0))) > 60) + FIT_MTIME(fit) = clktime(long(0)) + + # We cannot use clktime() directly since the previuos value + # of FIT_MTIME might already have a 4 secs increment. + + FIT_MTIME(fit) = FIT_MTIME(fit) + 4 + + # Now write default cards and im_userarea to disk. + nchars_ua = nchars_ua + diff + call fxf_write_header (im, fit, hdr_fd, nchars_ua, group) + + size = fstatl (hdr_fd, F_FILESIZE) + npad = FITS_BLOCK_CHARS - mod(size,FITS_BLOCK_CHARS) + + # If we are appending a new extension, we need to write padding to + # 2880 bytes blocks at the end of the file. + + if (mod(npad,FITS_BLOCK_CHARS) > 0 && + (FIT_NEWIMAGE(fit) == YES || append)) { + call amovki (0, Memi[mii], npad) + call flush (hdr_fd) + call seek (hdr_fd, EOF) + call write (hdr_fd, Memi[mii], npad) + } + call flush (hdr_fd) + + # Now open the original file and skip to the beginning of (group+1) + # to begin copying into hdr_fd. (end of temporary file in tmp$). + + if (FKS_OVERWRITE(fit) == YES) { + if (overwrite) { + call close (in_fd) + if (access (IM_PIXFILE(im), 0, 0) == YES) + call delete (IM_PIXFILE(im)) + call strcpy (Memc[outname], IM_PIXFILE(im), SZ_FNAME) + } + + in_fd = open (IM_HDRFILE(im), READ_ONLY, BINARY_FILE) + group = FIT_GROUP(fit) + call fxf_not_incache (im) + in_off = Memi[FIT_HDRPTR(fit)+group+1] + call seek (hdr_fd, EOF) + call seek (in_fd, in_off) + size = FITS_BLOCK_CHARS + + while (read (in_fd, Memi[mii], size) != EOF) + call write (hdr_fd, Memi[mii], size) + + call close (hdr_fd) + call close (in_fd) + + call fxf_ren_tmp (IM_PIXFILE(im), IM_HDRFILE(im), Memc[tmp2], 1, 1) + + # Change the acmode so we can change the modification and + # this way reset the cache for this file. + + IM_ACMODE(im) = READ_WRITE + call fxf_over_delete(im) + + } else { + if (adjust_header || overwrite) + call close (in_fd) + call close (hdr_fd) + + # If the header has been expanded then rename the temp file + # to the original name. + if (adjust_header) + call fxf_ren_tmp (Memc[outname], IM_PIXFILE(im), + Memc[tmp2], 1, 1) + } + + # Make sure we reset the modification time for the cached header + # since we have written a new version. This way the header will + # be read from disk next time the file is accessed. + + if (IM_ACMODE(im) == READ_WRITE || overwrite) { + # The modification time of a file in the cache can be different + # from another mod entry in another executable. We need to make + # sure that the mod time has changed in more than a second so that + # the other executable can read the header from disk and not + # from the cache entry. The FIT_MTIME value has already been + # changed by adding 4 seconds. (See above). + + call futime (IM_HDRFILE(im), NULL, FIT_MTIME(fit)) +# call futime (IM_HDRFILE(im), NULL, clktime(long(0))+4) + } + + if (FIT_GROUP(fit) == 0 || FIT_GROUP(fit) == -1) + call fxf_set_cache_time (im, false) + + # See if we need to add or change the value of EXTEND in the PHU. + if (FIT_XTENSION(fit) == YES && + (FIT_EXTEND(fit) == NO_KEYW || FIT_EXTEND(fit) == NO)) { + call fxf_update_extend (im) + } + + call sfree (sp) +end + + +# FXF_HDR_OFFSET -- Function to calculate the header offset for group number +# 'group'. + +int procedure fxf_hdr_offset (group, fit, pfd, acmode) + +int group #I extension number +pointer fit #I fits descriptor +pointer pfd #I pixel file descriptor +int acmode #I image acmode + +int hdr_off + +begin + if (FIT_NEWIMAGE(fit) == YES) + return (0) + + # Look for the beginning of the current group. + if (group == -1) { + # We are appending or creating a new FITS IMAGE. + hdr_off = FIT_EOFSIZE(fit) + } else { + call fxf_not_incache (FIT_IM(fit)) + hdr_off = Memi[FIT_HDRPTR(fit)+group] + } + + # If pixel file descriptor is empty for a newcopy or newimage + # in an existent image then the header offset is EOF. + + if (pfd == NULL && (acmode == NEW_COPY || acmode == NEW_IMAGE)) + hdr_off = EOF + + return (hdr_off) +end + + +# FXF_HEADER_DIFF -- Get the difference between the original header at open +# time and the one at closing time. + +procedure fxf_header_diff (im, group, acmode, hdr_off, diff, ualen) + +pointer im #I image descriptor +int group #I extension number +int acmode #I emage acmode +int hdr_off #I header offset for group +int diff #O difference +int ualen #O new header length + +char temp[LEN_CARD] +pointer hoff, poff, sp, pb, tb +int ua, fit, hdr_size, pixoff, clines, ulines, len, padlines +int merge, usize, excess, nheader_cards, rp, inherit, kmax, kmin +int strlen(), imaccf(), imgeti(), strcmp(), idb_findrecord() +int btoi(), strncmp() +bool imgetb() + +errchk open, fcopyo + +begin + fit = IM_KDES(im) + inherit = NO + + FIT_INHERIT(fit) = FKS_INHERIT(fit) + + # In READ_WRITE mode get the UA value of INHERIT only if it has + # change after _open(). + + if (acmode == READ_WRITE) { + if (imaccf (im, "INHERIT") == YES) { + inherit = btoi (imgetb (im, "INHERIT")) + if (inherit != FKS_INHERIT(fit)) + FIT_INHERIT(fit) = inherit + } + } + + # Allow inheritance only for extensions. + inherit = FIT_INHERIT(fit) + if (FIT_GROUP(fit) == 0) { + inherit = NO + FIT_INHERIT(fit) = inherit + } + # Scale the pixel offset to be zero base rather than the EOF base. + if (FIT_NEWIMAGE(fit) == NO) { + pixoff = FIT_PIXOFF(fit) - FIT_EOFSIZE(fit) + } else { + if ((hdr_off == EOF || hdr_off == 0)&& + (IM_NDIM(im) == 0 || FIT_NAXIS(fit) == 0)) { + diff = 0 + return + } + pixoff = FIT_PIXOFF(fit) - 1 + } + + ua = IM_USERAREA(im) + + if (FIT_NEWIMAGE(fit) == NO && inherit == YES) { + # Form an extension header by copying cards in the UA that + # do not belong in the global header nor in the old + # extension header if the image is open READ_WRITE. + + # Check if the file is still in cache. We need CACHELEN and + # CACHEHDR. + + call fxf_not_incache (im) + + len = strlen (Memc[ua]) + ulines = len / LEN_UACARD + clines = FIT_CACHEHLEN(fit) / LEN_UACARD + + call smark (sp) + call salloc (tb, len+1, TY_CHAR) + + # Now select those lines in UA that are not in fit_cache and + # put them in 'pb'. + + pb = tb + merge = NO + call fxf_match_str (ua, ulines, + FIT_CACHEHDR(fit), clines, merge, pb) + Memc[pb] = EOS + ualen = strlen (Memc[tb]) + + # Now copy the buffer pointed by 'pb' to UA. + call strcpy (Memc[tb], Memc[ua], ualen) + + call sfree (sp) + } + + # See also fitopix.x for an explanation of this call. + call fxf_mandatory_cards (im, nheader_cards) + + kmax = idb_findrecord (im, "DATAMAX", rp) + kmin = idb_findrecord (im, "DATAMIN", rp) + + if (IM_LIMTIME(im) < IM_MTIME(im)) { + # Keywords should not be in the UA. + if (kmax > 0) + call imdelf (im, "DATAMAX") + if (kmin > 0) + call imdelf (im, "DATAMIN") + + } else { + # Now update the keywords. If they are not in the UA we need + # to increase the number of mandatory cards. + + if (kmax == 0) + nheader_cards = nheader_cards + 1 + if (kmin == 0) + nheader_cards = nheader_cards + 1 + } + + # Determine if OBJECT or IM_TITLE have changed. IM_TITLE has + # priority. + + # If FIT_OBJECT is empty, then there was no OBJECT card at read + # time. If OBJECT is present now, then it was added now. If OBJECT + # was present but not now, the keyword was deleted. + + temp[1] = EOS + if (imaccf (im, "OBJECT") == YES) { + call imgstr (im, "OBJECT", temp, LEN_CARD) + # If its value is blank, then temp will be NULL + if (temp[1] == EOS) + call strcpy (" ", temp, LEN_CARD) + } + + if (temp[1] != EOS) + call strcpy (temp, FIT_OBJECT(fit), LEN_CARD) + else + nheader_cards = nheader_cards - 1 + + if (FIT_OBJECT(fit) == EOS) { + if (strcmp (IM_TITLE(im), FIT_TITLE(fit)) != 0) { + call strcpy (IM_TITLE(im), FIT_OBJECT(fit), LEN_CARD) + # The OBJECT keyword will be added. + nheader_cards = nheader_cards + 1 + } + } else { + # See if OBJECT has been deleted from UA. + if (temp[1] == EOS) + FIT_OBJECT(fit) = EOS + if (strcmp (IM_TITLE(im), FIT_TITLE(fit)) != 0) + call strcpy (IM_TITLE(im), FIT_OBJECT(fit), LEN_CARD) + } + + + # Too many mandatory cards if we are using the PHU in READ_WRITE mode. + # Because fxf_mandatory_cards gets call with FIT_NEWIMAGE set to NO, + # i.e. an extension. (12-9=3) + + if (FIT_XTENSION(fit) == NO && FIT_NEWIMAGE(fit) == NO) + nheader_cards = nheader_cards - 3 + + if (FIT_NEWIMAGE(fit) == NO && FIT_XTENSION(fit) == YES) { + + # Now take EXTNAME and EXTVER keywords off the UA if they are in + # there. The reason being they can be out of order. + + iferr (call imgstr (im, "EXTNAME", FIT_EXTNAME(fit), LEN_CARD)) { + FIT_EXTNAME(fit) = EOS + if (FKS_EXTNAME(fit) != EOS) { + call strcpy (FKS_EXTNAME(fit), FIT_EXTNAME(fit), LEN_CARD) + } else { + # We will not create EXTNAME keyword in the output header + nheader_cards = nheader_cards - 1 + } + } else { + call imdelf (im, "EXTNAME") + nheader_cards = nheader_cards + 1 + } + + if (imaccf (im, "EXTVER") == YES) { + FIT_EXTVER(fit) = imgeti (im, "EXTVER") + call imdelf (im, "EXTVER") + nheader_cards = nheader_cards + 1 + } + if (imaccf (im, "PCOUNT") == YES) { + call imdelf (im, "PCOUNT") + nheader_cards = nheader_cards + 1 + } + if (imaccf (im, "GCOUNT") == YES) { + call imdelf (im, "GCOUNT") + nheader_cards = nheader_cards + 1 + } + + if (IS_INDEFL(FIT_EXTVER(fit)) && !IS_INDEFL(FKS_EXTVER(fit))) + FIT_EXTVER(fit) = FKS_EXTVER(fit) + } + + # Finally if we are updating a BINTABLE with a PLIO_1 mask we need + # to add 3 to the mandatory cards since TFIELDS, TTYPE1, nor + # TFORM1 are included. ### Ugh!! + # Also add the Z cards. + + if (strncmp ("PLIO_1", FIT_EXTSTYPE(fit), 6) == 0) + nheader_cards = nheader_cards + 3 + 6 + IM_NDIM(im)*2 + + # Compute current header size rounded to a header block. + usize = strlen (Memc[ua]) + len = (usize / LEN_UACARD + nheader_cards) * LEN_CARD + len = FITS_LEN_CHAR(len / 2) + + # Ask for more lines if the header can or needs to be expanded. + padlines = FKS_PADLINES(fit) + + # Here we go over the FITS header area already allocated? + if (acmode == READ_WRITE || acmode == WRITE_ONLY) { + call fxf_not_incache(im) + hoff = FIT_HDRPTR(fit) + poff = FIT_PIXPTR(fit) + hdr_size = Memi[poff+group] - Memi[hoff+group] + ualen = len + diff = hdr_size - ualen + # If the header needs to be expanded add on the pad lines. + if (diff < 0) { + ualen = (usize/LEN_UACARD + nheader_cards + padlines) * LEN_CARD + ualen = FITS_LEN_CHAR(ualen / 2) + } + diff = hdr_size - ualen + } else if ((hdr_off == EOF || hdr_off == 0) && + (IM_NDIM(im) == 0 || FIT_NAXIS(fit) == 0)) { + hdr_size = len + ualen = len + } else { + hdr_size = pixoff + # The header can expand so add on the pad lines. + ualen = (usize / LEN_UACARD + nheader_cards + padlines) * LEN_CARD + ualen = FITS_LEN_CHAR(ualen / 2) + diff = hdr_size - ualen + } + + if (diff < 0 && FIT_EXPAND(fit) == NO) { + # We need to reduce the size of the UA becuase we are not + # going to expand the header. + excess = mod (nheader_cards * 81 + usize, 1458) + excess = excess + (((-diff-1400)/1440)*1458) + Memc[ua+usize-excess] = EOS + usize = strlen (Memc[ua]) + ualen = (usize / LEN_UACARD + nheader_cards) * LEN_CARD + ualen = FITS_LEN_CHAR(ualen / 2) + } +end + + +# FXF_WRITE_HDR -- Procedure to write header unit onto the PHU or EHU. + +procedure fxf_write_header (im, fit, hdr_fd, nchars_ua, group) + +pointer im #I image structure +pointer fit #I fits structure +int hdr_fd #I FITS header file descriptor +int nchars_ua #I header size +int group #I group number + +char temp[SZ_FNAME] +bool xtension, ext_append +pointer sp, spp, mii, rp, uap +char card[LEN_CARD], blank, keyword[SZ_KEYWORD], datestr[SZ_DATESTR] +int iso_cutover, n, i, sz_rec, up, nblanks, acmode, nbk, len, poff, diff +int pos, pcount, depth, subtype, maxlen, ndim + +long clktime() +int imaccf(), strlen(), fxf_ua_card(), envgeti() +int idb_findrecord(), strncmp(), btoi() +bool fxf_fpl_equald(), imgetb(), itob() +long note() +errchk write + +begin + call smark (sp) + call salloc (spp, FITS_BLOCK_CHARS*5, TY_CHAR) + call salloc (mii, FITS_BLOCK_CHARS, TY_INT) + + # Write out the standard, reserved header parameters. + n = spp + blank = ' ' + acmode = FIT_ACMODE(fit) + ext_append = ((acmode == NEW_IMAGE || acmode == NEW_COPY) && + (FKS_EXTNAME(fit) != EOS || !IS_INDEFL (FKS_EXTVER(fit)))) + + xtension = (FIT_XTENSION(fit) == YES) + if (FIT_NEWIMAGE(fit) == YES) + xtension = false + + subtype =0 + if ((FKS_SUBTYPE(fit) == FK_PLIO || + (strncmp("PLIO_1", FIT_EXTSTYPE(fit), 6) == 0)) && + IM_PL(im) != NULL) { + + subtype = FK_PLIO + ext_append = true + } + + # PLIO. Write BINTABLE header for a PLIO mask. + if (subtype == FK_PLIO) { + + if (IM_PFD(im) != NULL) { + call fxf_plinfo (im, maxlen, pcount, depth) + + # If we old heap has change in size, we need to + # resize it. + + if (acmode == READ_WRITE && pcount != FIT_PCOUNT(fit)) + call fxf_pl_adj_heap (im, hdr_fd, pcount) + } else { + pcount = FIT_PCOUNT(fit) + depth = DEF_PLDEPTH + } + + ndim = IM_NDIM(im) + call fxf_akwc ("XTENSION", "BINTABLE", 8, "Mask extension", n) + call fxf_akwi ("BITPIX", 8, "Bits per pixel", n) + call fxf_akwi ("NAXIS", ndim, "Number of axes", n) + call fxf_akwi ("NAXIS1", 8, "Number of bytes per line", n) + do i = 2, ndim { + call fxf_encode_axis ("NAXIS", keyword, i) + call fxf_akwi (keyword, IM_LEN(im,i), "axis length", n) + } + call fxf_akwi ("PCOUNT", pcount, "Heap size in bytes", n) + call fxf_akwi ("GCOUNT", 1, "Only one group", n) + + if (imaccf (im, "TFIELDS") == NO) + call fxf_akwi ("TFIELDS", 1, "1 Column field", n) + if (imaccf (im, "TTYPE1") == NO) { + call fxf_akwc ("TTYPE1", "COMPRESSED_DATA", 16, + "Type of PLIO_1 data", n) + } + call sprintf (card, LEN_CARD, "PI(%d)") + call pargi(maxlen) + call fxf_filter_keyw (im, "TFORM1") + len = strlen (card) + call fxf_akwc ("TFORM1", card, len, "Variable word array", n) + + } else { + if (xtension) + call fxf_akwc ("XTENSION", "IMAGE", 5, "Image extension", n) + else + call fxf_akwb ("SIMPLE", YES, "Fits standard", n) + + if (FIT_NAXIS(fit) == 0 || FIT_BITPIX(fit) == 0) + call fxf_setbitpix (im, fit) + + call fxf_akwi ("BITPIX", FIT_BITPIX(fit), "Bits per pixel", n) + call fxf_akwi ("NAXIS", FIT_NAXIS(fit), "Number of axes", n) + + do i = 1, FIT_NAXIS(fit) { + call fxf_encode_axis ("NAXIS", keyword, i) + call fxf_akwi (keyword, FIT_LENAXIS(fit,i), "Axis length", n) + } + + if (xtension) { + call fxf_akwi ("PCOUNT", 0, "No 'random' parameters", n) + call fxf_akwi ("GCOUNT", 1, "Only one group", n) + } else { + if (imaccf (im, "EXTEND") == NO) + i = NO + else { + # Keyword exists but it may be in the wrong position. + # Remove it and write it now. + + i = btoi (imgetb (im, "EXTEND")) + call fxf_filter_keyw (im, "EXTEND") + } + if (FIT_EXTEND(fit) == YES) + i = YES + call fxf_akwb ("EXTEND", i, "File may contain extensions", n) + FIT_EXTEND(fit) = YES + } + } + + # Delete BSCALE and BZERO just in case the application puts them + # in the UA after the pixels have been written. The keywords + # should not be there since the FK does not allow reading pixels + # with BITPIX -32 and BSCALE and BZERO. If the application + # really wants to circumvent this restriction the code below + # will defeat that. The implications are left to the application. + # This fix is put in here to save the ST Hstio interface to be + # a victim of the fact that in v2.12 the BSCALE and BZERO keywords + # are left in the header for the user to see or change. Previous + # FK versions, the keywords were deleted from the UA. + + if ((IM_PIXTYPE(im) == TY_REAL || IM_PIXTYPE(im) == TY_DOUBLE) + && (FIT_TOTPIX(fit) > 0 && FIT_BITPIX(fit) <= 0)) { + + call fxf_filter_keyw (im, "BSCALE") + call fxf_filter_keyw (im, "BZERO") + } + + # Do not write BSCALE and BZERO if they have the default + # values (1.0, 0.0). + + if (IM_PIXTYPE(im) == TY_USHORT) { + call fxf_filter_keyw (im, "BSCALE") + call fxf_akwd ("BSCALE", 1.0d0, + "REAL = TAPE*BSCALE + BZERO", NDEC_REAL, n) + call fxf_filter_keyw (im, "BZERO") + call fxf_akwd ("BZERO", 32768.0d0, "", NDEC_REAL, n) + } else if (FIT_PIXTYPE(fit) != TY_REAL && + FIT_PIXTYPE(fit) != TY_DOUBLE && IM_ACMODE(im) != NEW_COPY) { + # Now we have TY_SHORT or TY_(INT,LONG). + # Check the keywords only if they have non_default values. + + # Do not add the keywords if they have been deleted. + if (!fxf_fpl_equald(1.0d0, FIT_BSCALE(fit), 4)) { + if ((imaccf (im, "BSCALE") == NO) && + fxf_fpl_equald (1.0d0, FIT_BSCALE(fit), 4)) { + call fxf_akwd ("BSCALE", FIT_BSCALE(fit), + "REAL = TAPE*BSCALE + BZERO", NDEC_REAL, n) + } + } + if (!fxf_fpl_equald(0.0d0, FIT_BZERO(fit), 4) ) { + if (imaccf (im, "BZERO") == NO && + fxf_fpl_equald (1.0d0, FIT_BZERO(fit), 4)) + call fxf_akwd ("BZERO", FIT_BZERO(fit), "", NDEC_REAL, n) + } + } + + uap = IM_USERAREA(im) + + if (idb_findrecord (im, "ORIGIN", rp) == 0) { + call strcpy (FITS_ORIGIN, temp, LEN_CARD) + call fxf_akwc ("ORIGIN", + temp, strlen(temp), "FITS file originator", n) + } else if (rp - uap > 10*81) { + # Out of place; do not change the value. + call imgstr (im, "ORIGIN", temp, LEN_CARD) + call fxf_filter_keyw (im, "ORIGIN") + call fxf_akwc ("ORIGIN", + temp, strlen(temp), "FITS file originator", n) + } + + if (xtension) { + # Update the cache in case these values have changed + # in the UA. + call fxf_set_extnv (im) + + if (FIT_EXTNAME(fit) != EOS) { + call strcpy (FIT_EXTNAME(fit), temp, LEN_CARD) + call fxf_akwc ("EXTNAME", + temp, strlen(temp), "Extension name", n) + } + if (!IS_INDEFL (FIT_EXTVER(fit))) { + call fxf_akwi ("EXTVER", + FIT_EXTVER(fit), "Extension version", n) + } + if (idb_findrecord (im, "INHERIT", rp) > 0) { + # See if keyword is at the begining of the UA + if (rp - uap > 11*81) { + call fxf_filter_keyw (im, "INHERIT") + call fxf_akwb ("INHERIT", + FIT_INHERIT(fit), "Inherits global header", n) + } else if (acmode != READ_WRITE) + call imputb (im, "INHERIT", itob(FIT_INHERIT(fit))) + } else { + call fxf_akwb ("INHERIT", + FIT_INHERIT(fit), "Inherits global header", n) + } + } + + # Dates after iso_cutover use ISO format dates. + iferr (iso_cutover = envgeti (ENV_ISOCUTOVER)) + iso_cutover = DEF_ISOCUTOVER + + # Encode the "DATE" keyword (records create time of imagefile). + call fxf_encode_date (clktime(long(0)), datestr, SZ_DATESTR, + "ISO", iso_cutover) + len = strlen (datestr) + + if (idb_findrecord (im, "DATE", rp) == 0) { + # Keyword is not in the UA, created with current time + call fxf_akwc ("DATE", + datestr, len, "Date FITS file was generated", n) + } else { + if (acmode == READ_WRITE) { + # Keep the old DATE, change only the IRAF-TLM keyword value + call imgstr (im, "DATE", datestr, SZ_DATESTR) + } + # See if the keyword is out of order. + if (rp - uap > 12*81) { + call fxf_filter_keyw (im, "DATE") + + call fxf_akwc ("DATE", + datestr, len, "Date FITS file was generated", n) + } else + call impstr (im, "DATE", datestr) + } + + # Encode the "IRAF_TLM" keyword (records time of last modification). + if (acmode == NEW_IMAGE || acmode == NEW_COPY) { + FIT_MTIME(fit) = IM_MTIME(im) + } + + call fxf_encode_date (FIT_MTIME(fit), datestr, SZ_DATESTR, "TLM", 2010) +# call fxf_encode_date (clktime(long(0))+4, datestr, SZ_DATESTR, "TLM", 2010) + len = strlen (datestr) + + if (idb_findrecord (im, "IRAF-TLM", rp) == 0) { + call fxf_akwc ("IRAF-TLM", + datestr, len, "Time of last modification", n) + } else if (rp - uap > 13*81) { + call fxf_filter_keyw (im, "IRAF-TLM") + call fxf_akwc ("IRAF-TLM", + datestr, len, "Time of last modification", n) + } else + call impstr (im, "IRAF-TLM", datestr) + + # Create DATA(MIN,MAX) keywords only if they have the real + # min and max of the data. + + if (IM_LIMTIME(im) >= IM_MTIME(im)) { + if (idb_findrecord (im, "DATAMIN", rp) == 0) { + call fxf_akwr ("DATAMIN", + IM_MIN(im), "Minimum data value", NDEC_REAL, n) + } else + call imputr (im, "DATAMIN", IM_MIN(im)) + + if (idb_findrecord (im, "DATAMAX", rp) == 0) { + call fxf_akwr ("DATAMAX", + IM_MAX(im), "Maximum data value",NDEC_REAL, n) + } else + call imputr (im, "DATAMAX", IM_MAX(im)) + } + + if (FIT_OBJECT(fit) != EOS) { + if (idb_findrecord (im, "OBJECT", rp) == 0) { + call fxf_akwc ("OBJECT", FIT_OBJECT(fit), + strlen (FIT_OBJECT(fit)), "Name of the object observed", n) + } else if (rp - uap > 14*81) { + call fxf_filter_keyw (im, "OBJECT") + call fxf_akwc ("OBJECT", FIT_OBJECT(fit), + strlen (FIT_OBJECT(fit)), "Name of the object observed", n) + } else + call impstr (im, "OBJECT", FIT_OBJECT(fit)) + } + + # Write Compression keywords for PLIO BINTABLE. +# if (subtype == FK_PLIO && IM_PFD(im) != NULL && ext_append) { + if (subtype == FK_PLIO) { + call fxf_akwb ("ZIMAGE", YES, "Is a compressed image", n) + call fxf_akwc ("ZCMPTYPE", "PLIO_1", 6, "IRAF image masks", n) + call fxf_akwi ("ZBITPIX", 32, "BITPIX for uncompressed image",n) + + # We use IM_NDIM and IM_LEN here because FIT_NAXIS and _LENAXIS + # are not available for NEW_IMAGE mode. + + ndim = IM_NDIM(im) + call fxf_akwi ("ZNAXIS", ndim, "NAXIS for uncompressed image",n) + do i = 1, ndim { + call fxf_encode_axis ("ZNAXIS", keyword, i) + call fxf_akwi (keyword, IM_LEN(im,i), "Axis length", n) + } + call fxf_encode_axis ("ZTILE", keyword, 1) + call fxf_akwi (keyword, IM_LEN(im,1), "Axis length", n) + do i = 2, ndim { + call fxf_encode_axis ("ZTILE", keyword, i) + call fxf_akwi (keyword, 1, "Axis length", n) + } + call fxf_encode_axis ("ZNAME", keyword, 1) + call fxf_akwc (keyword, "depth", 5, "PLIO mask depth", n) + call fxf_encode_axis ("ZVAL", keyword, 1) + call fxf_akwi (keyword, depth, "Parameter value", n) + } + + # Write the UA now. + up = 1 + nbk = 0 + n = n - spp + sz_rec = 1440 + while (fxf_ua_card (fit, im, up, card) == YES) { + call amovc (card, Memc[spp+n], LEN_CARD) + n = n + LEN_CARD + + if (n == 2880) { + nbk = nbk + 1 + call miipak (Memc[spp], Memi[mii], sz_rec*2, TY_CHAR, MII_BYTE) + call write (hdr_fd, Memi[mii], sz_rec) + n = 0 + } + } + + # Write the last record. + nblanks = 2880 - n + call amovkc (blank, Memc[spp+n], nblanks) + rp = spp+n+nblanks-LEN_CARD + + # If there are blocks of trailing blanks, write them now. + if (n > 0) + nbk = nbk + 1 + diff = nchars_ua - nbk * 1440 + if (diff > 0) { + if (n > 0) { + call miipak (Memc[spp], Memi[mii], sz_rec*2, TY_CHAR, MII_BYTE) + call write (hdr_fd, Memi[mii], sz_rec) + } + + if (group < 0) { + # We are writing blocks of blanks on a new_copy + # image which has group=-1 here. Use diff. + + nbk = diff / 1440 + } else { + pos = note (hdr_fd) + call fxf_not_incache(im) + poff = FIT_PIXPTR(fit) + nbk = (Memi[poff+group] - pos) + nbk = nbk / 1440 + } + call amovkc (blank, Memc[spp], 2880) + call miipak (Memc[spp], Memi[mii], sz_rec*2, TY_CHAR, MII_BYTE) + do i = 1, nbk-1 + call write (hdr_fd, Memi[mii], sz_rec) + + call amovkc (blank, Memc[spp], 2880) + rp = spp+2880-LEN_CARD + } + + call amovc ("END", Memc[rp], 3) + call miipak (Memc[spp], Memi[mii], sz_rec*2, TY_CHAR, MII_BYTE) + call write (hdr_fd, Memi[mii], sz_rec) + # PLIO: write the mask data to the new extension. + if (subtype == FK_PLIO && IM_PFD(im) != NULL) { + call fxf_plwrite (im, hdr_fd) + IM_PFD(im) = NULL + } + + call flush (hdr_fd) + call sfree (sp) +end + + +# FXF_UA_CARD -- Fetch a single line from the user area, trim newlines and +# pad with blanks to size LEN_CARD in order to create an unknown keyword card. +# At present user area information is assumed to be in the form of FITS card +# images, less then or equal to 80 characters and delimited by a newline. + +int procedure fxf_ua_card (fit, im, up, card) + +pointer fit #I points to the fits descriptor +pointer im #I pointer to the IRAF image +int up #I next character in the unknown string +char card[ARB] #O FITS card image + +char cval +int stat, diff +char chfetch() +int strmatch() + +begin + if (chfetch (UNKNOWN(im), up, cval) == EOS) + return (NO) + else { + up = up - 1 + stat = NO + + while (stat == NO) { + diff = up + call fxf_make_card (UNKNOWN(im), up, card, 1, LEN_CARD, '\n') + diff = up - diff + if (card[1] == EOS) + break + + if (strmatch ( card, "^GROUPS ") != 0) + stat = NO + else if (strmatch (card, "^GCOUNT ") != 0) + stat = NO + else if (strmatch (card, "^PCOUNT ") != 0) + stat = NO + else if (strmatch (card, "^BLOCKED ") != 0) + stat = NO + else if (strmatch (card, "^PSIZE ") != 0) + stat = NO + else + stat = YES + } + + return (stat) + } +end + + +# FXF_SETBITPIX -- Set the FIT_BITPIX to the pixel datatype value. + +procedure fxf_setbitpix (im, fit) + +pointer im #I image descriptor +pointer fit #I fit descriptor + +int datatype +errchk syserr, syserrs + +begin + datatype = IM_PIXTYPE(im) + + switch (datatype) { + case TY_SHORT, TY_USHORT: + FIT_BITPIX(fit) = FITS_SHORT + case TY_INT, TY_LONG: + FIT_BITPIX(fit) = FITS_LONG + case TY_REAL: + FIT_BITPIX(fit) = FITS_REAL + case TY_DOUBLE: + FIT_BITPIX(fit) = FITS_DOUBLE + default: + call flush (STDOUT) + call syserr (SYS_FXFUPHBTYP) + } +end + + +# FXF_MAKE_ADJ_COPY -- Copy a FITS file into a new one, changing the size +# of a fits header. + +procedure fxf_make_adj_copy (in_fd, out_fd, hdr_off, pixoff, chars_ua) + +int in_fd #I input FITS descriptor +int out_fd #I output FITS descriptor +int hdr_off #I offset to be beginning of the ua to be resized +int pixoff #I offset to be pixel area following hdroff +int chars_ua #I size of the new UA (user area) in units of chars + +pointer mii, sp +int nk, nblocks, junk, size_ua +errchk read, write +int read() + +begin + call smark (sp) + call salloc (mii, FITS_BLOCK_CHARS, TY_INT) + + # Number of 1440 chars block up to the beginning of the UA to change. + nblocks = hdr_off / FITS_BLOCK_CHARS + + # Copy everything up to hdroff. + call seek (in_fd, BOF) + do nk = 1, nblocks { + junk = read (in_fd, Memi[mii], FITS_BLOCK_CHARS) + call write (out_fd, Memi[mii], FITS_BLOCK_CHARS) + } + + # Size of the new UA. + size_ua = FITS_LEN_CHAR(chars_ua) + nblocks = size_ua / FITS_BLOCK_CHARS + + # Put a blank new header in the meantime. + call amovki( 0, Memi[mii], FITS_BLOCK_CHARS) + do nk = 1, nblocks + call write (out_fd, Memi[mii], FITS_BLOCK_CHARS) + + # Position after the current input header to continue + # copying. + + call flush (out_fd) + call seek (in_fd, pixoff) + call fcopyo (in_fd, out_fd) + call flush (out_fd) + call sfree (sp) +end + + +# FXF_SET_CACHE_MTIME -- Procedure to reset the modification time on the +# cached entry for the file pointed by 'im'. + +procedure fxf_set_cache_time (im, overwrite) + +pointer im #I image descriptor +bool overwrite #I invalidate entry if true + +pointer sp, hdrfile, fit +long fi[LEN_FINFO] +int finfo(), cindx +errchk syserr, syserrs +bool streq() + +include "fxfcache.com" + +begin + call smark (sp) + call salloc (hdrfile, SZ_PATHNAME, TY_CHAR) + + fit = IM_KDES(im) + + call fpathname (IM_HDRFILE(im), Memc[hdrfile], SZ_PATHNAME) + if (finfo (Memc[hdrfile], fi) == ERR) + call syserrs (SYS_FOPEN, IM_HDRFILE(im)) + + # Search the header file cache for the named image. + do cindx = 1, rf_cachesize { + if (rf_fit[cindx] == NULL) + next + + if (streq (Memc[hdrfile], rf_fname[1,cindx])) { + # Reset cache + if (IM_ACMODE(im) == READ_WRITE || overwrite) { + # Invalidate entry. + call mfree (rf_pextv[cindx], TY_INT) + call mfree (rf_pextn[cindx], TY_CHAR) + call mfree (rf_pixp[cindx], TY_INT) + call mfree (rf_hdrp[cindx], TY_INT) + call mfree (rf_fit[cindx], TY_STRUCT) + call mfree (rf_hdr[cindx], TY_CHAR) + rf_fname[1,cindx] = EOS + rf_mtime[cindx] = 0 + rf_fit[cindx] = NULL + + } else { + # While we are appending we want to keep the cache entry + # in the slot. + rf_mtime[cindx] = FI_MTIME(fi) + } + break + } + } + + call sfree (sp) +end + + +# FXF_SET_EXTNV -- Procedure to write UA value of EXTNAME and EXTVER +# into the cache slot. + +procedure fxf_set_extnv (im) + +pointer im #I image descriptor + +pointer fit, sp, hdrfile +int cindx, ig, extn, extv +errchk syserr, syserrs +bool bxtn, bxtv +bool streq() + +include "fxfcache.com" + +begin + fit = IM_KDES(im) + ig = FIT_GROUP(fit) + + call smark (sp) + call salloc (hdrfile, SZ_PATHNAME, TY_CHAR) + + # Search the header file cache for the named image. + do cindx = 1, rf_cachesize { + if (rf_fit[cindx] == NULL) + next + + if (streq (Memc[hdrfile], rf_fname[1,cindx])) { + bxtn = (FIT_EXTNAME(fit) != EOS) + bxtv = (!IS_INDEFL (FIT_EXTVER(fit))) + # Reset cache + if (IM_ACMODE(im) == READ_WRITE) { + if (bxtn) { + extn = rf_pextn[cindx] + # Just replace the value + call strcpy (FIT_EXTNAME(fit), Memc[extn+LEN_CARD*ig], + LEN_CARD) + } + if (bxtv) { + extv = rf_pextv[cindx] + # Just replace the value + Memi[extv+ig] = FIT_EXTVER(fit) + } + } + break + } + } + + call sfree (sp) +end + + +# FXF_REN_TMP -- Rename input file to output file. +# +# The output file may already exists in which case it is replaced. +# Because this operation is critical it is heavily error checked and +# has retries to deal with networking cases. + +procedure fxf_ren_tmp (in, out, tmp, ntry, nsleep) + +char in[ARB] #I file to replace output +char out[ARB] #O output file (replaced if it exists) +char tmp[ARB] #I temporary name for in until rename succeeds +int ntry #I number of retries for rename +int nsleep #I Number of seconds to sleep before retry + +int i, stat, err, access(), protect(), errget() +bool replace, prot +pointer errstr + +errchk access, protect, rename, delete, salloc + +begin +#call eprintf ("fxf_ren_tmp (%s, %s, %s, %d %d)\n") +#call pargstr (in) +#call pargstr (out) +#call pargstr (tmp) +#call pargi (ntry) +#call pargi (nsleep) + err = 0; errstr = NULL + + iferr { + # Move original output out of the way. + # Don't delete it in case of an error. + replace = (access (out, 0, 0) == YES) + prot = false + if (replace) { + prot = (protect (out, QUERY_PROTECTION) == YES) + if (prot) + stat = protect (out, REMOVE_PROTECTION) + do i = 0, max(0,ntry) { +#call eprintf ("1 rename (%s, %s)\n") +#call pargstr (out) +#call pargstr (tmp) + ifnoerr (call rename (out, tmp)) { + err = 0 + break + } + if (errstr == NULL) + call salloc (errstr, SZ_LINE, TY_CHAR) + err = errget (Memc[errstr], SZ_LINE) + if (err == 0) + err = SYS_FMKCOPY + call tsleep (nsleep) + } + if (err > 0) + call error (err, Memc[errstr]) + } + + # Now rename the input to the output. + do i = 0, max(0,ntry) { +#call eprintf ("2 rename (%s, %s)\n") +#call pargstr (in) +#call pargstr (out) + ifnoerr (call rename (in, out)) { + err = 0 + break + } + if (errstr == NULL) + call salloc (errstr, SZ_LINE, TY_CHAR) + err = errget (Memc[errstr], SZ_LINE) + if (err == 0) + err = SYS_FMKCOPY + call tsleep (nsleep) + } + if (err > 0) + call error (err, Memc[errstr]) + if (prot) + stat = protect (out, SET_PROTECTION) + + # If the rename has succeeded delete the original data. + if (replace) { +#call eprintf ("delete (%s)\n") +#call pargstr (tmp) + call delete (tmp) + } + } then + call erract (EA_ERROR) +end + + +# FXF_OVER_TMP -- Rename an entry from the cache. + +procedure fxf_over_delete (im) + +pointer im #I image descriptor + +pointer fname, sp +bool streq() +int cindx +include "fxfcache.com" + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + + call fpathname (IM_HDRFILE(im), Memc[fname], SZ_PATHNAME) + + # Remove the image from the FITS cache if found. + do cindx=1, rf_cachesize { + if (rf_fit[cindx] == NULL) + next + if (streq (Memc[fname], rf_fname[1,cindx])) { + call mfree (rf_pextv[cindx], TY_INT) + call mfree (rf_pextn[cindx], TY_CHAR) + call mfree (rf_pixp[cindx], TY_INT) + call mfree (rf_hdrp[cindx], TY_INT) + call mfree (rf_fit[cindx], TY_STRUCT) + call mfree (rf_hdr[cindx], TY_CHAR) + rf_fit[cindx] = NULL + } + } + + call sfree (sp) +end + + +# FXF_UPDATE_EXTEND -- Add or change the value of the EXTEND keyword in PHU. +# Sometimes the input PHU has not been created by the FK and the EXTEND keyw +# might not be there as the standard tells when an extension is appended +# to a file. + +procedure fxf_update_extend (im) + +pointer im #I image descriptor + +pointer sp, hdrfile, tmp1, tmp2 +int fd, fdout, i, nch, nc, cfit +char line[LEN_CARD], blank, cindx +bool streq() +int open(), naxis, read(), strncmp(), fnroot() +long note() +errchk open, fxf_ren_tmp + +include "fxfcache.com" +define cfit_ 91 + +begin + call smark (sp) + call salloc (hdrfile, SZ_PATHNAME, TY_CHAR) + + fd = open (IM_HDRFILE(im), READ_WRITE, BINARY_FILE) + + # Look for EXTEND keyword and change its value in place. + nc = 0 + while (read (fd, line, 40) != EOF) { + nc = nc + 1 + call achtbc (line, line, LEN_CARD) + if (strncmp ("EXTEND ", line, 8) == 0) { + line[30] = 'T' + call seek (fd, note(fd)-40) + call achtcb (line, line, LEN_CARD) + call write (fd, line, 40) + call close (fd) + goto cfit_ + } else if (strncmp ("END ", line, 8) == 0) + break + } + + # The EXTEND card is not in the header. Insert it after the + # last NAXISi in a temporary file, rename after this. + + call salloc (tmp1, SZ_FNAME, TY_CHAR) + i = fnroot (IM_HDRFILE(im), Memc[tmp1], SZ_FNAME) + call mktemp (Memc[tmp1], Memc[tmp1], SZ_FNAME) + + fdout = open (Memc[tmp1], NEW_FILE, BINARY_FILE) + + call seek (fd, BOF) + do i = 0, nc-2 { + nch = read (fd, line, 40) + call write (fdout, line, 40) + call achtbc(line, line, LEN_CARD) + if (strncmp ("NAXIS ", line, 8) == 0) + call fxf_geti (line, naxis) + else if (strncmp ("NAXIS", line, 5) == 0){ + if ((line[6] - '0') == naxis) { + # Now create the EXTEND card in the output file. + call fxf_encodeb ("EXTEND", YES, line, + "File may contain extensions") + call achtcb (line, line , LEN_CARD) + call write (fdout, line, 40) + } + } + } + + if (mod (nc, 36) == 0) { + # We have to write one END card and 35 blank card. + blank = ' ' + call amovkc (blank, line, 80) + call amovc ("END", line, 3) + call achtcb (line, line , LEN_CARD) + call write (fdout, line, 40) + call amovkc (blank, line, 80) + call achtcb (line, line , LEN_CARD) + for (i=1; i < 36; i=i+1) + call write (fdout, line, 40) + } else { + nch = read (fd, line, 40) + call write (fdout, line, 40) + } + + # Read one more line to synchronize. + nch = read (fd, line, 40) + + # Copy the rest of the file. + call fcopyo (fd, fdout) + + call close (fd) + call close (fdout) + + call salloc (tmp2, SZ_FNAME, TY_CHAR) + call strcpy (Memc[tmp1], Memc[tmp2], SZ_FNAME) + call strcat ("A", Memc[tmp2], SZ_FNAME) + call fxf_ren_tmp (Memc[tmp1], IM_HDRFILE(im), Memc[tmp2], 1, 1) + +cfit_ + # Now reset the value in the cache + call fpathname (IM_HDRFILE(im), Memc[hdrfile], SZ_PATHNAME) + + # Search the header file cache for the named image. + do cindx = 1, rf_cachesize { + if (rf_fit[cindx] == NULL) + next + + if (streq (Memc[hdrfile], rf_fname[1,cindx])) { + # Reset cache + cfit = rf_fit[cindx] + FIT_EXTEND(cfit) = YES + break + } + } + + call sfree (sp) +end diff --git a/sys/imio/iki/fxf/fxfupk.x b/sys/imio/iki/fxf/fxfupk.x new file mode 100644 index 00000000..b6b158ae --- /dev/null +++ b/sys/imio/iki/fxf/fxfupk.x @@ -0,0 +1,155 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <mach.h> +include "fxf.h" + +# FXFUPK.X -- Routines to upack an IEEE vector into native format. +# +# fxf_unpack_data (cbuf, npix, pixtype, bscale, bzero) +# fxf_altmr (a, b, npix, bscale, bzero) +# fxf_altmd (a, b, npix, bscale, bzero) +# fxf_altmu (a, b, npix) +# fxf_astmr (a, b, npix, bscale, bzero) + +define NBITS_DOU (SZB_CHAR * SZ_DOUBLE) +define IOFF 1 + + +# FITUPK -- Unpack cbuf in place from FITS binary format to local machine type. + +procedure fxf_unpack_data (cbuf, npix, pixtype, bscale, bzero) + +char cbuf[ARB] #U buffer with input,output data +int npix #I number of pixels in buffer +int pixtype #I input pixtype +double bscale #I scale factor to applied to input data +double bzero #I offset to applied to input data + +int nchars, nbytes +bool fp_equald() +errchk syserr + +include <szpixtype.inc> + +begin + nchars = npix * pix_size[pixtype] + nbytes = nchars * SZB_CHAR + + switch (pixtype) { + case TY_SHORT, TY_USHORT: + if (BYTE_SWAP2 == YES) + call bswap2 (cbuf, 1, cbuf, 1, nbytes) + if (pixtype == TY_USHORT) + call fxf_altmu (cbuf, cbuf, npix) + + case TY_INT, TY_LONG: + if (BYTE_SWAP4 == YES) + call bswap4 (cbuf, 1, cbuf, 1, nbytes) + + case TY_REAL: + ### Rather than perform this test redundantly a flag should be + ### passed in from the high level code telling the routine whether + ### or not it should apply the scaling. Testing for floating + ### point equality (e.g. bscale != 1.0) is not portable. + + if (!fp_equald(bscale,1.0d0) || !fp_equald(bzero,0.0d0)) { + if (BYTE_SWAP4 == YES) + call bswap4 (cbuf, 1, cbuf, 1, nbytes) + call iscl32 (cbuf, cbuf, npix, bscale, bzero) + } else + call ieevupkr (cbuf, cbuf, npix) + + case TY_DOUBLE: + ### Same as above. + if (!fp_equald(bscale,1.0d0) || !fp_equald(bzero,0.0d0)) { + if (BYTE_SWAP4 == YES) + call bswap4 (cbuf, 1, cbuf, 1, nbytes) + call iscl64 (cbuf, cbuf, npix, bscale, bzero) + } else + call ieevupkd (cbuf, cbuf, npix) + + default: + call syserr (SYS_FXFUPKDTY) + } +end + + +# FXF_ALTMR -- Scale a real array. + +procedure fxf_altmr (a, b, npix, bscale, bzero) + +int a[ARB] #I input array +real b[ARB] #O output array +int npix #I number of pixels +double bscale, bzero #I scaling parameters + +int i + +begin + do i = 1, npix + b[i] = a[i] * bscale + bzero +end + + +# FXF_ALTMD -- Scale a double array. + +procedure fxf_altmd (a, b, npix, bscale, bzero) + +int a[ARB] #I input array +double b[ARB] #O output array +int npix #I number of pixels +double bscale, bzero #I scaling parameters + +int i + +begin + ### int and double are not the same size so if this operation is + ### to allow an in-place conversion it must go right to left instead + ### of left to right. + + do i = npix, 1, -1 + b[i] = a[i] * bscale + bzero +end + + +# FXF_ALTMU -- Scale an array to unsigned short. + +procedure fxf_altmu (a, b, npix) + +short a[ARB] #I input array +char b[ARB] #O output array +int npix #I number of pixels + +int i +pointer sp, ip + +begin + call smark (sp) + call salloc (ip, npix+1, TY_INT) + + do i = 1, npix + Memi[ip+i] = a[i] + 32768 + + call achtlu (Memi[ip+1], b, npix) + call sfree (sp) +end + + +# FXF_ASTMR -- Scale an input short array into a real. + +procedure fxf_astmr (a, b, npix, bscale, bzero) + +short a[ARB] #I input array +real b[ARB] #O output array +int npix #I number of pixels +double bscale, bzero #I scaling parameters + +int i + +begin + do i = npix, 1, -1 + b[i] = a[i] * bscale + bzero +end + + diff --git a/sys/imio/iki/fxf/mkpkg b/sys/imio/iki/fxf/mkpkg new file mode 100644 index 00000000..859d6f47 --- /dev/null +++ b/sys/imio/iki/fxf/mkpkg @@ -0,0 +1,42 @@ +# Build or update the FITS kernel. + +$checkout libex.a lib$ +$update libex.a +$checkin libex.a lib$ +$exit + +libex.a: + fxfaccess.x fxf.h + fxfaddpar.x <imhdr.h> <imio.h> <mach.h> fxf.h + fxfclose.x fxf.h <imhdr.h> <imio.h> + fxfcopy.x <error.h> + fxfctype.x fxf.h <ctype.h> + fxfdelete.x <error.h> <imhdr.h> fxf.h fxfcache.com + fxfencode.x fxf.h <time.h> + fxfexpandh.x fxf.h fxfcache.com <fset.h> <imhdr.h> <imio.h>\ + <mach.h> <mii.h> + fxfget.x fxf.h <ctype.h> + fxfhextn.x fxf.h <imhdr.h> <imio.h> + fxfksection.x <error.h> fxf.h <ctotok.h> <imhdr.h> <lexnum.h> + fxfmkcard.x + fxfnull.x fxf.h + fxfopen.x fxf.h fxfcache.com <error.h> <imhdr.h> <imio.h>\ + fxfcache.com <finfo.h> <fset.h> <mach.h> <mii.h>\ + <pmset.h> + fxfopix.x fxf.h <fset.h> <imhdr.h> <imio.h> <error.h> <mach.h> + fxfpak.x fxf.h <mach.h> + fxfplread.x fxf.h <imhdr.h> <imio.h> <mach.h> <plset.h> + fxfplwrite.x fxf.h <imio.h> <mach.h> <mii.h> <plset.h> <pmset.h>\ + <imhdr.h> + fxfrcard.x fxf.h <mii.h> + fxfrdhdr.x fxf.h <imhdr.h> <imio.h> <mach.h> + fxfrename.x <error.h> fxf.h fxfcache.com + fxfrfits.x fxf.h fxfcache.com <ctype.h> <finfo.h> <fset.h>\ + <imhdr.h> <imio.h> <imset.h> <mach.h> <time.h> + fxfupdhdr.x fxf.h <fio.h> <fset.h> <imhdr.h> <imio.h>\ + fxfcache.com <error.h> <finfo.h> <mach.h> <mii.h>\ + <time.h> + fxfupk.x fxf.h <mach.h> + zfiofxf.x fxf.h <fio.h> <fset.h> <imhdr.h> <imio.h> <knet.h>\ + <mach.h> + ; diff --git a/sys/imio/iki/fxf/zfiofxf.x b/sys/imio/iki/fxf/zfiofxf.x new file mode 100644 index 00000000..97b36264 --- /dev/null +++ b/sys/imio/iki/fxf/zfiofxf.x @@ -0,0 +1,546 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> +include <knet.h> +include <fio.h> +include <fset.h> +include <imio.h> +include <imhdr.h> +include "fxf.h" + +# ZFIOFXF -- FITS kernel virtual file driver. This maps the actual +# FITS file into the virtual pixel file expected by IMIO. + + +# FXFZOP -- Open the file driver for i/o. The filename has appended the +# string "_nnnnn", where 'nnnnn' is the FIT descriptor to the structure +# defined in "fit.h". + +procedure fxfzop (pkfn, mode, status) + +char pkfn[ARB] #I packed virtual filename from FIO +int mode #I file access mode (ignored) +int status #O output status - i/o channel if successful + +pointer im, fit +int ip, indx, channel, strldx(), ctoi() +bool lscale, lzero, bfloat, fxf_fpl_equald() +char fname[SZ_PATHNAME] + +begin + # Separate the FIT descriptor from the file name. + call strupk (pkfn, fname, SZ_PATHNAME) + + ip = strldx ("_", fname) + indx = ip + 1 + if (ctoi (fname, indx, fit) <= 0) { + status = ERR + return + } + + # Determine if we have a Fits Kernel non supported + # data format; i.e. Bitpix -32 or -64 and BSCALE and/or + # BZERO with non default values. + + ### Only "low level" routines can be falled from a file driver: + ### high level routines like syserr cannot be used due to + ### recursion/reentrancy problems. + # We are calling syserrs at this level because we want to + # give the application the freedom to manipulate the FITS header + # at will and not imposing restriction at that level. + + im = FIT_IM(fit) + lscale = fxf_fpl_equald (1.0d0, FIT_BSCALE(fit), 1) + lzero = fxf_fpl_equald (0.0d0, FIT_BZERO(fit), 1) + + # Determine if scaling is necessary. + #bfloat = (!lscale || !lzero) + #if (bfloat && (FIT_BITPIX(fit) == -32 || FIT_BITPIX(fit) == -64)) { + # FIT_IOSTAT(fit) = ERR + # #call syserrs (SYS_FXFRDHSC,IM_HDRFILE(im)) + # status = ERR + # return + #} + + fname[ip] = EOS + call strpak (fname, fname, SZ_PATHNAME) + + # Open the file. + call zopnbf (fname, mode, channel) + if (channel == ERR) { + status = ERR + return + } + + status = fit + FIT_IO(fit) = channel +end + + +# FITZCL -- Close the FIT binary file driver. + +procedure fxfzcl (chan, status) + +int chan #I FIT i/o channel +int status #O output status + +pointer fit + +begin + fit = chan + call zclsbf (FIT_IO(fit), status) +end + + +# FXFZRD -- Read the FIT file (header and pixel data). An offset pointer +# needs to be set to point to the data portion of the file. If we are reading +# pixel data, the scale routine fxf_unpack_data is called. We need to keep +# a counter (npix_read) with the current number of pixels unpacked since we +# don't want to convert beyond the total number of pixels; where the last +# block of data read can contain zeros or garbage up to a count of 2880 bytes. + +procedure fxfzrd (chan, obuf, nbytes, boffset) + +int chan #I FIT i/o channel +char obuf[ARB] #O output buffer +int nbytes #I nbytes to be read +int boffset #I file offset at which read commences + +pointer fit, im +int ip, pixtype, nb +int status, totpix, npix +int datasizeb, pixoffb, nb_skipped, i +double dtemp +real rtemp, rscale, roffset + +include <szpixtype.inc> + +begin + fit = chan + im = FIT_IM(fit) + FIT_IOSTAT(fit) = OK + + totpix = IM_PHYSLEN(im,1) + do i = 2, IM_NPHYSDIM(im) + totpix = totpix * IM_PHYSLEN(im,i) + + if (FIT_ZCNV(fit) == YES) { + if (FIT_PIXTYPE(fit) != TY_REAL && FIT_PIXTYPE(fit) != TY_DOUBLE) { + call fxf_cnvpx (im, totpix, obuf, nbytes, boffset) + return + } + } + + pixtype = IM_PIXTYPE(im) + datasizeb = totpix * (pix_size[pixtype] * SZB_CHAR) + pixoffb = (FIT_PIXOFF(fit) - 1) * SZB_CHAR + 1 + + # We can read the data directly into the caller's output buffer as + # any FITS kernel input conversions are guaranteed to not make the + # data smaller. + + call zardbf (FIT_IO(fit), obuf, nbytes, boffset) + call zawtbf (FIT_IO(fit), status) + if (status == ERR) { + FIT_IOSTAT(fit) = ERR + return + } + + ### boffset is 1-indexed, so one would expect (boffset/SZB_CHAR) to + ### be ((boffset - 1) * SZB_CHAR + 1). This is off by one from what + ### is being calculated, so if PIXOFF and boffset point to the same + ### place IP will be one, which happens to be the correct array index. + ### Nonehtless expressions like this should be written out so that + ### they can be verified easily by reading them. Any modern compiler + ### will optimize the expression, we don't have to do this in the + ### source code. + + ip = FIT_PIXOFF(fit) - boffset/SZB_CHAR + if (ip <= 0) + ip = 1 + + nb_skipped = boffset - pixoffb + if (nb_skipped <= 0) + nb = min (status + nb_skipped, datasizeb) + else + nb = min (status, datasizeb - nb_skipped) + npix = max (0, nb / (pix_size[pixtype] * SZB_CHAR)) + + if (FIT_ZCNV(fit) == YES) { + if (FIT_PIXTYPE(fit) == TY_REAL) { + # This is for scaling -32 (should not be allowed) + call fxf_zaltrr(obuf[ip], npix, FIT_BSCALE(fit), FIT_BZERO(fit)) + } else if (FIT_PIXTYPE(fit) == TY_DOUBLE) { + # This is for scaling -64 data (should not be allowed) + call fxf_zaltrd(obuf[ip], npix, FIT_BSCALE(fit), FIT_BZERO(fit)) + } + } else { + call fxf_unpack_data (obuf[ip], + npix, pixtype, FIT_BSCALE(fit), FIT_BZERO(fit)) + } +end + +procedure fxf_zaltrr (data, npix, bscale, bzero) + +real data[ARB], rt +int npix +double bscale, bzero + +int i + +begin + call ieevupkr (data, data, npix) + do i = 1, npix { + data[i] = data[i] * bscale + bzero + } +end + + +procedure fxf_zaltrd (data, npix, bscale, bzero) + +double data[ARB] +int npix +double bscale, bzero + +int i + +begin + call ieevupkd (data, data, npix) + do i = 1, npix + data[i] = data[i] * bscale + bzero +end + + + +# FXFZWR -- Write to the output file. + +procedure fxfzwr (chan, ibuf, nbytes, boffset) + +int chan #I QPF i/o channel +char ibuf[ARB] #O data buffer +int nbytes #I nbytes to be written +int boffset #I file offset + +pointer fit, im, sp, obuf +bool noconvert, lscale, lzero, bfloat +int ip, op, pixtype, npix, totpix, nb, nchars, i +int datasizeb, pixoffb, nb_skipped, obufsize + +bool fxf_fpl_equald() + +include <szpixtype.inc> + +begin + fit = chan + im = FIT_IM(fit) + FIT_IOSTAT(fit) = OK + + # We don't have to pack the data if it is integer and we don't need + # to byte swap; the data buffer can be written directly out. + + + # Determine if we are writing into an scaled floating point data + # unit; i.e. bitpix > 0 and BSCALE or/and BZERO with non default + # values. This is an error since we are not supporting this + # combination for writing at this time. + + lscale = fxf_fpl_equald (1.0d0, FIT_BSCALE(fit), 1) + lzero = fxf_fpl_equald (0.0d0, FIT_BZERO(fit), 1) + + # Determine if scaling is necessary. + bfloat = (!lscale || !lzero) + if (bfloat && + (IM_PIXTYPE(im) == TY_REAL || IM_PIXTYPE(im) == TY_DOUBLE)) { + FIT_IOSTAT(fit) = ERR + return + } + + pixtype = IM_PIXTYPE(im) + noconvert = ((pixtype == TY_SHORT && BYTE_SWAP2 == NO) || + ((pixtype == TY_INT || pixtype == TY_LONG) && BYTE_SWAP4 == NO)) + + if (noconvert) { + call zawrbf (FIT_IO(fit), ibuf, nbytes, boffset) + return + } + + # Writing pixel data to an image is currently illegal if on-the-fly + # conversion is in effect, as on-the-fly conversion is currently only + # available for reading. + + if (FIT_ZCNV(fit) == YES) { + FIT_IOSTAT(fit) = ERR + return + } + + totpix = IM_PHYSLEN(im,1) + do i = 2, IM_NPHYSDIM(im) + totpix = totpix * IM_PHYSLEN(im,i) + + datasizeb = totpix * (pix_size[pixtype] * SZB_CHAR) + pixoffb = (FIT_PIXOFF(fit) - 1) * SZB_CHAR + 1 + + ### Same comments as for fxfzrd apply here. + ### There doesn't appear to be any support here for byte data like + ### in fxfzwr. This must mean that byte images are read-only. + ### This shouldn't be necessary, but we shouldn't try to do anything + ### about it until the fxf_byte_short issue is addressed. + + ip = FIT_PIXOFF(fit) - boffset / SZB_CHAR + if (ip <= 0) + ip = 1 + + nb_skipped = boffset - pixoffb + if (nb_skipped <= 0) + nb = min (nbytes + nb_skipped, datasizeb) + else + nb = min (nbytes, datasizeb - nb_skipped) + npix = max (0, nb / (pix_size[pixtype] * SZB_CHAR)) + + if (npix == 0) + return + + # We don't do scaling (e.g. BSCALE/BZERO) when writing. All the + # generated FITS files in this interface are ieee fits standard. + ### I didn't look into it but I don't understand this; when accessing + ### a BSCALE image read-write, it should be necessary to scale both + ### when reading and writing if the application sees TY_REAL pixels. + ### When writing a new image I suppose the application would take + ### care of any scaling. + + # Convert any pixel data in the input buffer to the binary format + # required for FITS and write it out. Any non-pixel data in the + # buffer should be left as-is. + + obufsize = (nbytes + SZB_CHAR-1) / SZB_CHAR + + call smark (sp) + call salloc (obuf, obufsize, TY_CHAR) + + # Preserve any leading non-pixel data. + op = 1 + if (ip > 1) { + nchars = min (obufsize, ip - 1) + call amovc (ibuf[1], Memc[obuf], nchars) + op = op + nchars + } + + # Convert and output the pixels. + call fxf_pak_data (ibuf[ip], Memc[obuf+op-1], npix, pixtype) + op = op + npix * pix_size[pixtype] + + # Preserve any remaining non-pixel data. + nchars = obufsize - op + 1 + if (nchars > 0) + call amovc (ibuf[op], Memc[obuf+op-1], nchars) + + # Write out the data. + call zawrbf (FIT_IO(fit), Memc[obuf], nbytes, boffset) + + call sfree (sp) +end + + +# FXFZWT -- Return the number of bytes transferred in the last i/o request. + +procedure fxfzwt (chan, status) + +int chan #I QPF i/o channel +int status #O i/o channel status + +pointer fit, im + +begin + fit = chan + im = FIT_IM(fit) + + # A file driver returns status for i/o only in the AWAIT routine; + # hence any i/o errors occurring in the FK itself are indicated by + # setting FIT_IOSTAT. Otherwise the actual i/o operation must have + # been submitted, and we call zawtbf to wait for i/o, and get status. + + if (FIT_IOSTAT(fit) != OK) + status = FIT_IOSTAT(fit) + else + call zawtbf (FIT_IO(fit), status) + + # FIT_ZBYTES has the correct number of logical bytes that need + # to be passed to fio since we are expanding the buffer size + # from byte to short or real and short to real. + + if (status > 0) { + if (FIT_PIXTYPE(fit) == TY_UBYTE) + status = FIT_ZBYTES(fit) + else if (FIT_PIXTYPE(fit) == TY_SHORT && IM_PIXTYPE(im) == TY_REAL) + status = FIT_ZBYTES(fit) + } +end + + +# FXFZST -- Query device/file parameters. + +procedure fxfzst (chan, param, value) + +int chan #I FIT i/o channel +int param #I parameter to be returned +int value #O parameter value + +pointer fit, im +int i, totpix, szb_pixel, szb_real + +include <szpixtype.inc> + +begin + fit = chan + im = FIT_IM(fit) + + totpix = IM_PHYSLEN(im,1) + do i = 2, IM_NPHYSDIM(im) + totpix = totpix * IM_PHYSLEN(im,i) + + szb_pixel = pix_size[IM_PIXTYPE(im)] * SZB_CHAR + szb_real = SZ_REAL * SZB_CHAR + + call zsttbf (FIT_IO(fit), param, value) + + if (param == FSTT_FILSIZE) { + switch (FIT_PIXTYPE(fit)) { + case TY_SHORT: + if (IM_PIXTYPE(im) == TY_REAL) { + value = value + int ((totpix * SZ_SHORT * SZB_CHAR) / + 2880. + .5) * 2880 + } + case TY_UBYTE: + if (IM_PIXTYPE(im) == TY_SHORT) + value = value + int (totpix/2880. + 0.5)*2880 + else if (IM_PIXTYPE(im) == TY_REAL) + value = value + int(totpix*(szb_real-1)/2880. + 0.5) * 2880 + } + } +end + + +# FXF_CNVPX -- Convert FITS type BITPIX = 8 to SHORT or REAL depending +# on the value of BSCALE, BZERO (1, 32768 is already iraf supported as ushort +# and is not treated in here). If BITPIX=16 and BSCALE and BZERO are +# non-default then the pixels are converted to REAL. + +procedure fxf_cnvpx (im, totpix, obuf, nbytes, boffset) + +pointer im #I Image descriptor +int totpix #I Total number of pixels +char obuf[ARB] #O Output data buffer +int nbytes #I Size in bytes of the output buffer +int boffset #I Byte offset into the virtual image + +pointer sp, buf, fit, op +double bscale, bzero +int ip, nelem, pfactor +int pixtype, nb, buf_size, bzoff, nboff +int status, offset, npix +int datasizeb, pixoffb, nb_skipped + +include <szpixtype.inc> + +begin + fit = IM_KDES(im) + bscale = FIT_BSCALE(fit) + bzero = FIT_BZERO(fit) + + ip = FIT_PIXOFF(fit) - boffset/SZB_CHAR + if (ip <= 0) + ip = 1 + + # The beginning of the data portion in bytes. + pixoffb = (FIT_PIXOFF(fit)-1) * SZB_CHAR + 1 + + # Determine the factor to applied: size(im_pixtype)/size(fit_pixtype) + if (FIT_PIXTYPE(fit) == TY_UBYTE) { + if (IM_PIXTYPE(im) == TY_REAL) + pfactor = SZ_REAL * SZB_CHAR + else # TY_SHORT + pfactor = SZB_CHAR + datasizeb = totpix + } else if (FIT_PIXTYPE(fit) == TY_SHORT) { + pfactor = SZ_REAL / SZ_SHORT + pixtype = TY_SHORT + datasizeb = totpix * (pix_size[pixtype] * SZB_CHAR) + } else { + FIT_IOSTAT(fit) = ERR + return + } + + # We need to map the virtual image of type im_pixtype to the actual + # file of type fit_pixtype. 'nbytes' is the number of bytes to read + # from the virtual image. To find out how many fit_pixtype bytes + # we need to read from disk we need to subtract the FITS + # header size (if boffset is 1) from nbytes and then divide + # the resultant value by the convertion factor. + # We then add the size of the header if necessary. + + # Determine the offset into the pixel area. + nboff = boffset - pixoffb + if (nboff > 0) { + nelem = nboff / pfactor + offset = nelem + pixoffb + } else { + # Keep the 1st boffset. + bzoff = boffset + offset = boffset + } + + # Calculates the number of elements to convert. We keep the offset from + # the beginning of the unit (bzoff) and not from file's 1st byte. + + nelem = nbytes - (pixoffb - bzoff + 1) + nelem = nelem / pfactor + buf_size = nelem + (pixoffb - bzoff + 1) + if (buf_size*pfactor > nbytes && ip == 1) + buf_size = (nbytes - 1) / pfactor + 1 + + # Allocate space for TY_SHORT + call smark(sp) + call salloc (buf, buf_size/SZB_CHAR, TY_SHORT) + + call zardbf (FIT_IO(fit), Mems[buf], buf_size, offset) + call zawtbf (FIT_IO(fit), status) + if (status == ERR) { + FIT_IOSTAT(fit) = ERR + call sfree (sp) + return + } + + # Map the number of bytes of datatype FIT_PIXTYPE to + # IM_PIXTYPE for use in zfxfwt(). + + if (status*pfactor >= nbytes) + FIT_ZBYTES(fit) = nbytes + else + FIT_ZBYTES(fit) = status * pfactor + + nb_skipped = offset - pixoffb + if (nb_skipped <= 0) + nb = min (status + nb_skipped, datasizeb) + else + nb = min (status, datasizeb - nb_skipped) + + switch (FIT_PIXTYPE(fit)) { + case TY_UBYTE: + npix = max (0, nb) + if (IM_PIXTYPE(im) == TY_SHORT) + call achtbs (Mems[buf+ip-1], obuf[ip], npix) + else { + # Scaled from byte to REAL. + call achtbl (Mems[buf+ip-1], obuf[ip], npix) + call fxf_altmr (obuf[ip], obuf[ip], npix, bscale, bzero) + } + case TY_SHORT: + op = buf + ip - 1 + npix = max (0, nb / (pix_size[pixtype] * SZB_CHAR)) + if (BYTE_SWAP2 == YES) + call bswap2 (Mems[op], 1, Mems[op], 1, npix*SZB_CHAR) + call fxf_astmr (Mems[op], obuf[ip], npix, bscale, bzero) + } + + call sfree (sp) +end diff --git a/sys/imio/iki/iki.com b/sys/imio/iki/iki.com new file mode 100644 index 00000000..1c8ef719 --- /dev/null +++ b/sys/imio/iki/iki.com @@ -0,0 +1,10 @@ +# IKI.COM -- Image Kernel Interface global common. + +int k_nkernels, k_nextn, k_sbufused, k_defimtype, k_inherit +int k_kernel[MAX_IMEXTN], k_extn[MAX_IMEXTN], k_pattern[MAX_IMEXTN] +int k_table[LEN_KERNEL,MAX_KERNELS] +char k_kname[SZ_KNAME,MAX_KERNELS] +char k_sbuf[SZ_IKISBUF] + +common /ikicom/ k_nkernels, k_nextn, k_sbufused, k_defimtype, k_inherit, + k_kernel, k_extn, k_pattern, k_table, k_kname, k_sbuf diff --git a/sys/imio/iki/iki.h b/sys/imio/iki/iki.h new file mode 100644 index 00000000..be7a6bc0 --- /dev/null +++ b/sys/imio/iki/iki.h @@ -0,0 +1,35 @@ +# IKI.H -- Image Kernel Interface global definitions. + +define MAX_KERNELS 10 # max loaded IKI kernels +define MAX_LENEXTN 4 # max length header filename extension +define MIN_LENEXTN 2 # min length header filename extension +define MAX_IMEXTN 64 # max image extension patterns +define SZ_IKISBUF 512 # string buffer for IKI common +define SZ_KNAME 4 # internal kernel name "oif,fxf,.." + +# IMTYPE specifies the default type for new images. +define ENV_IMTYPE "imtype" +define DEF_IMTYPE "oif,noinherit" + +# IMEXTN specifies the mapping between image types and file extensions. +define ENV_IMEXTN "imextn" +define DEF_IMEXTN "oif:imh fxf:fits,fit plf:pl qpf:qp stf:hhh,??h" + +# The standard test image. +define STD_TESTIMAGE "dev$pix" +define DEF_TESTIMAGE "dev$pix.imh" + +define LEN_KERNEL 9 # length of a kernel entry in k_table +define IKI_KNAME k_kname[1,$1] # image kernel name +define IKI_OPEN k_table[1,$1] # open/create image +define IKI_CLOSE k_table[2,$1] # close image +define IKI_OPIX k_table[3,$1] # open/create pixel file +define IKI_UPDHDR k_table[4,$1] # update image header +define IKI_ACCESS k_table[5,$1] # test existence or legal type +define IKI_COPY k_table[6,$1] # fast copy of entire image +define IKI_DELETE k_table[7,$1] # delete image +define IKI_RENAME k_table[8,$1] # rename image +define IKI_FLAGS k_table[9,$1] # driver flags + +# IKI driver flags. +define IKF_NOCREATE 1 # kernel cannot create new images diff --git a/sys/imio/iki/ikiaccess.x b/sys/imio/iki/ikiaccess.x new file mode 100644 index 00000000..83736b4f --- /dev/null +++ b/sys/imio/iki/ikiaccess.x @@ -0,0 +1,128 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include "iki.h" + +# IKI_ACCESS -- Determine if the named image exists, and if so, return the +# the index of the IKI kernel to be used to access the image, else return 0 if +# the named image is not found. If multiple images exist with the same name +# (e.g. but with different image types) then ERR is returned. An NEW_IMAGE +# access mode may be specified to associate an extension with an image kernel +# without testing for the existence of an image. If the input image name did +# not specify an extension or what appeared to be an extension was just a . +# delimited field, we will patch up the ROOT and EXTN strings to the real +# values. + +int procedure iki_access (image, root, extn, acmode) + +char image[ARB] #I image/group name +char root[ARB] #O image/group file name +char extn[ARB] #O image/group file extension +int acmode + +bool first_time +int i, k, status, op +pointer sp, osroot, fname, textn, fextn, ip +data first_time /true/ + +bool fnullfile() +int gstrcpy(), strlen() +errchk fpathname, syserrs +include "iki.com" + +begin + call smark (sp) + call salloc (osroot, SZ_PATHNAME, TY_CHAR) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + call salloc (textn, MAX_LENEXTN, TY_CHAR) + call salloc (fextn, MAX_LENEXTN, TY_CHAR) + + # The first call makes sure the IKI kernels are loaded into the kernel + # table. + + if (first_time) { + call iki_init() + first_time = false + } + + call iki_parse (image, root, extn) + if (fnullfile (root)) { + call sfree (sp) + return (1) + } + + repeat { + # Convert to absolute pathname to render names like file + # and ./file equivalent. Add a dummy file extension first + # to cause escape sequence encoding of any .DDDD etc. files + # which may be part of the root image name. + + op = gstrcpy (root, Memc[fname], SZ_PATHNAME) + call strcpy (".x", Memc[fname+op], SZ_PATHNAME-op+1) + call fpathname (Memc[fname], Memc[osroot], SZ_PATHNAME) + Memc[osroot+strlen(Memc[osroot])-2] = EOS + + # Escape any $ in the pathname since we are still in VOS land. + op = 1 + for (ip=osroot; Memc[ip] != EOS; ip=ip+1) { + if (Memc[ip] == '$' || Memc[ip] == '[') { + root[op] = '\\' + op = op + 1 + } + root[op] = Memc[ip] + op = op + 1 + } + + root[op] = EOS + + # Select an image kernel by calling the access function in each + # loaded kernel until somebody claims the image. If multiple + # kernels claim the image the image specification (name) is + # ambiguous and we don't know which image was intended, an error. + # Note that in the case of a new image, the access function + # tests only the legality of the extn. + + k = 0 + for (i=1; i <= k_nkernels; i=i+1) { + call strcpy (extn, Memc[textn], MAX_LENEXTN) + call zcall5 (IKI_ACCESS(i), i,root,Memc[textn],acmode,status) + + if (status == YES) { + if (k == 0) { + # Stop on the first access if an explicit extension + # was given. + + k = i + call strcpy (Memc[textn], Memc[fextn], MAX_LENEXTN) + if (extn[1] != EOS) + break + + } else { + # The image name is ambiguous. + call sfree (sp) + return (ERR) + } + } + } + + # Valid image using kernel K. + if (k != 0) { + call strcpy (Memc[fextn], extn, MAX_LENEXTN) + call sfree (sp) + return (k) + } + + # If the search failed and an extension was given, maybe what + # we thought was an extension was really just part of the root + # filename. Try again with the extn folded into the root. + + if (status == NO && extn[1] != EOS) { + call strcpy (image, root, SZ_PATHNAME) + extn[1] = EOS + } else + break + } + + call sfree (sp) + return (0) +end diff --git a/sys/imio/iki/ikiclose.x b/sys/imio/iki/ikiclose.x new file mode 100644 index 00000000..e4b2ced9 --- /dev/null +++ b/sys/imio/iki/ikiclose.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include <imio.h> +include "iki.h" + +# IKI_CLOSE -- Physically close an image opened under the IKI. It is not +# necessary to update the image header or flush any pixel data, as IMIO will +# already have performed those functions. + +procedure iki_close (im) + +pointer im #I image descriptor + +int status +include "iki.com" + +begin + iferr (call zcall2 (IKI_CLOSE(IM_KERNEL(im)), im, status)) + status = ERR + if (status == ERR) + call syserrs (SYS_IKICLOSE, IM_NAME(im)) +end diff --git a/sys/imio/iki/ikicopy.x b/sys/imio/iki/ikicopy.x new file mode 100644 index 00000000..31df1970 --- /dev/null +++ b/sys/imio/iki/ikicopy.x @@ -0,0 +1,62 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include "iki.h" + +# IKI_COPY -- Fast copy of an entire image or group of images. This function +# is provided at the IKI level since the kernel has explicit knowledge of the +# storage format and hence may be able to copy the image by means much simpler +# and faster way than those available to the high level software. + +procedure iki_copy (old, new) + +char old[ARB] #I name of old image +char new[ARB] #I name of new image + +int k, n, status +pointer sp, old_root, old_extn, new_root, new_extn +int iki_access() +bool streq() +errchk syserrs + +include "iki.com" + +begin + call smark (sp) + call salloc (old_root, SZ_PATHNAME, TY_CHAR) + call salloc (old_extn, MAX_LENEXTN, TY_CHAR) + call salloc (new_root, SZ_PATHNAME, TY_CHAR) + call salloc (new_extn, MAX_LENEXTN, TY_CHAR) + + # Verify that the old image exists and determine its type. + k = iki_access (old, Memc[old_root], Memc[old_extn], READ_ONLY) + if (k < 0) + call syserrs (SYS_IKIAMBIG, old) + else if (k == 0) + call syserrs (SYS_IKIIMNF, old) + + # Make sure we will not be clobbering an existing image. Ignore + # attempts to rename an image onto itself. + + n = iki_access (new, Memc[new_root], Memc[new_extn], 0) + if (n > 0) { + if (streq (Memc[old_root], Memc[new_root])) + if (streq (Memc[old_extn], Memc[new_extn])) { + call sfree (sp) + return + } + call syserrs (SYS_IKICLOB, new) + } else { + # New name is new root plus legal extn for old image. + call iki_parse (new, Memc[new_root], Memc[new_extn]) + call strcpy (Memc[old_extn], Memc[new_extn], MAX_LENEXTN) + } + + # Copy the image. + call zcall6 (IKI_COPY(k), k, Memc[old_root], Memc[old_extn], + Memc[new_root], Memc[new_extn], status) + if (status == ERR) + call syserrs (SYS_IKICOPY, old) + + call sfree (sp) +end diff --git a/sys/imio/iki/ikidelete.x b/sys/imio/iki/ikidelete.x new file mode 100644 index 00000000..a172980b --- /dev/null +++ b/sys/imio/iki/ikidelete.x @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include "iki.h" + +# IKI_DELETE -- Delete an image or group of images. + +procedure iki_delete (image) + +char image[ARB] #I name of image + +int k, status +pointer sp, root, extn +int iki_access() +bool fnullfile() + +errchk syserrs +include "iki.com" + +begin + if (fnullfile (image)) + return + + call smark (sp) + call salloc (root, SZ_PATHNAME, TY_CHAR) + call salloc (extn, MAX_LENEXTN, TY_CHAR) + + # Verify that the image exists and determine its type. + k = iki_access (image, Memc[root], Memc[extn], 0) + if (k < 0) + call syserrs (SYS_IKIAMBIG, image) + else if (k == 0) + call syserrs (SYS_IKIIMNF, image) + + # Delete the image. + call zcall4 (IKI_DELETE(k), k, Memc[root], Memc[extn], status) + if (status == ERR) + call syserrs (SYS_IKIDEL, image) + + call sfree (sp) +end diff --git a/sys/imio/iki/ikiextn.x b/sys/imio/iki/ikiextn.x new file mode 100644 index 00000000..a5f2aa12 --- /dev/null +++ b/sys/imio/iki/ikiextn.x @@ -0,0 +1,372 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <ctype.h> +include <imhdr.h> +include "iki.h" + +# IKIEXTN.X -- Image extension handling. This package is used to map image +# file extensions to image types and vice versa. +# +# iki_extninit (imtype, def_imtype, imextn, def_imextn) +# status = iki_validextn (kernel, extn) +# status = iki_getextn (kernel, index, extn, maxch) +# value = iki_getpar (param) +# +# iki_extninit initializes the image extension handling package. This parses +# the lists of extensions and patterns and builds an internal descriptor which +# will be used by the other routines for extension handling. iki_validextn +# tests whether a given extension is valid for a particular image kernel +# (type of image). iki_getextn is used with an index argument to get a list +# of the extensions for a particular image type. iki_getpar queries the value +# of IKI global parameters. + +define SZ_IMTYPE 128 +define SZ_IMEXTN 1024 + + +# IKI_EXTNINIT -- Initialize the image extension handling package. This is +# typically done once when IKI is first initialized. Changes to the image +# typing environment made subsequently have no effect unless the package is +# reinitialized. + +int procedure iki_extninit (env_imtype, def_imtype, env_imextn, def_imextn) + +char env_imtype[ARB] #I imtype environment variable +char def_imtype[ARB] #I default imtype value string +char env_imextn[ARB] #I imextn environment variable +char def_imextn[ARB] #I default imextn value string + +int kset[MAX_KERNELS] +pointer sp, ip, ip_save, imtype, imextn, strval +int op, delim, status, nchars, i, j, kernel +int envfind(), iki_getfield(), gstrcpy(), iki_validextn() +bool streq(), envgetb() + +include "iki.com" + +begin + call smark (sp) + call salloc (imtype, SZ_IMTYPE, TY_CHAR) + call salloc (imextn, SZ_IMEXTN, TY_CHAR) + call salloc (strval, SZ_FNAME, TY_CHAR) + + status = OK + + # Get the imtype string. The value of the env_imtype variable is used + # if the variable is found, otherwise the default is used. + + Memc[imtype] = EOS + if (env_imtype[1] != EOS) + if (envfind (env_imtype, Memc[imtype], SZ_IMTYPE) <= 0) + Memc[imtype] = EOS + if (Memc[imtype] == EOS) + call strcpy (def_imtype, Memc[imtype], SZ_IMTYPE) + + # Get the imextn string. The value of the env_imextn variable is used + # if the variable is found, otherwise the default is used. + + Memc[imextn] = EOS + if (env_imextn[1] != EOS) + if (envfind (env_imextn, Memc[imextn], SZ_IMEXTN) <= 0) + Memc[imextn] = EOS + if (Memc[imextn] == EOS) + call strcpy (def_imextn, Memc[imextn], SZ_IMEXTN) + + # Process imextn. This specifies the set of valid extensions for + # each image type. This must be done before processing imtype below, + # since iki_validextn can be used when processing imtype. The imextn + # string is of the form "<kernel>:<extn>[,<extn>...] ..." where + # <kernel> is the IKI kernel name (k_kname) and <extn> is a regular + # expression to be used to test for a matching file extension. + # For example, imextn = "oif:imh stf:hhh,??h fits:,fits,fit". + + k_nextn = 0 + k_sbufused = 0 + call aclri (kset, MAX_KERNELS) + + # Process the user extension string first followed by the builtin + # defaults. Anything given in the user string takes precedence + # while anything omitted uses the builtin defaults instead (if there + # is no user imextn this processes the default string twice). + + do i = 1, 2 { + if (i > 1) + call strcpy (def_imextn, Memc[imextn], SZ_IMEXTN) + + ip = imextn + while (Memc[ip] != EOS && IS_WHITE(Memc[ip])) + ip = ip + 1 + + repeat { + # Get the kernel name. + if (iki_getfield (ip, Memc[strval], SZ_FNAME, delim) <= 0) + break + call strlwr (Memc[strval]) + if (delim != ':') { + status = ERR + break + } + + # Lookup kernel. + kernel = 0 + do j = 1, k_nkernels { + if (streq (Memc[strval], k_kname[1,j])) { + kernel = j + break + } + } + if (kernel <= 0) { + status = ERR + break + } + + # Process the list of extension patterns. + op = k_sbufused + 1 + ip_save = ip + + while (iki_getfield (ip, Memc[strval], SZ_FNAME, delim) > 0) { + # call strlwr (Memc[strval]) + + # Skip it if we already have something for this kernel. + if (kset[kernel] == 0) { + # Get a new extension descriptor. + if (k_nextn >= MAX_IMEXTN) { + status = ERR + break + } else + k_nextn = k_nextn + 1 + + # Save the kernel index associated with this extension. + k_kernel[k_nextn] = kernel + + # Save the extension string. + k_extn[k_nextn] = op + nchars = gstrcpy(Memc[strval],k_sbuf[op],SZ_IKISBUF-op) + op = op + nchars + 1 + + # Save the strmatch pattern for the extension. + k_pattern[k_nextn] = op + k_sbuf[op] = '^'; op = op + 1 + nchars = gstrcpy(Memc[strval],k_sbuf[op],SZ_IKISBUF-op) + op = op + nchars + 1 + } + + ip_save = ip + if (delim != ',') + break + } + + kset[kernel] = 1 + k_sbufused = op - 1 + + } until (Memc[ip] == EOS) + } + + # Process imtype. This sets the default image type for new images. + # For example, imtype = "oif,inherit" would create OIF (.imh) images + # by default, inheriting the old image type if a newcopy image is + # being written. + + k_defimtype = 1 + k_inherit = NO + ip = imtype + kernel = 0 + + while (iki_getfield (ip, Memc[strval], SZ_FNAME, delim) > 0) { + call strlwr (Memc[strval]) + + # Check for the inherit/noinherit keywords. + if (streq (Memc[strval], "inherit")) { + k_inherit = YES + next + } + if (streq (Memc[strval], "noinherit")) { + k_inherit = NO + next + } + + # Scan the kernels to see if we have a kernel name. + if (kernel <= 0) + do i = 1, k_nkernels + if (streq (Memc[strval], k_kname[1,i])) { + kernel = i + break + } + + # Check for a valid imagefile extension. + if (kernel <= 0) + kernel = iki_validextn (0, Memc[strval]) + } + + if (kernel <= 0) + status = ERR + else + k_defimtype = kernel + + if (envgetb ("ikidebug")) + call iki_debug ("IKI debug:", STDERR, 0) + + call sfree (sp) + return (status) +end + + +# IKI_VALIDEXTN -- Determine if the given imagefile extension is valid for +# the given image kernel (image type). If kernel=0 the extensions for all +# kernels are examined. If a valid match is found the kernel index is +# returned as the function value, otherwise 0 is returned. + +int procedure iki_validextn (kernel, extn) + +int kernel #I kernel index, zero for all kernels +char extn[ARB] #I extension to be tested + +int i, ip +int strmatch() +include "iki.com" + +begin + do i = 1, k_nextn + if (kernel == 0 || k_kernel[i] == kernel) { + ip = strmatch (extn, k_sbuf[k_pattern[i]]) + if (ip > 0 && extn[ip] == EOS) + return (k_kernel[i]) + } + + return (0) +end + + +# IKI_GETEXTN -- Get an entry from the list of valid extensions (actually +# extension patterns) for the given image kernel. If kernel=0 all entries +# are returned. The kernel index for the output extension is returned as +# the function value. ERR is returned if the requested extension does not +# exist. + +int procedure iki_getextn (kernel, index, extn, maxch) + +int kernel #I kernel index, zero for all kernels +int index #I extension number (1 indexed) +char extn[ARB] #O extension +int maxch #I max chars out + +int i, n +include "iki.com" + +begin + n = 0 + do i = 1, k_nextn + if (kernel == 0 || k_kernel[i] == kernel) { + n = n + 1 + if (index == n) { + call strcpy (k_sbuf[k_extn[i]], extn, maxch) + return (k_kernel[i]) + } + } + + return (ERR) +end + + +# IKI_GETPAR -- Return the value of an IKI global parameter (integer valued). + +int procedure iki_getpar (param) + +char param[ARB] #I parameter name + +bool streq() +include "iki.com" + +begin + if (streq (param, "inherit")) + return (k_inherit) + else if (streq (param, "defimtype")) + return (k_defimtype) +end + + +# IKI_GETFIELD -- Get the next field from a punctuation or whitespace +# delimited list. The length of the field is returned as the function value. +# EOF is returned at the end of the list. Zero can be returned if a field +# is zero length, e.g. in "foo,,foo" the second field is zero length. + +int procedure iki_getfield (ip, outstr, maxch, delim) + +pointer ip #U string pointer +char outstr[ARB] #O receives string +int maxch #I max chars out +int delim #O delimiter char + +int op, ch + +begin + # Skip any leading whitespace. + while (Memc[ip] != EOS && IS_WHITE(Memc[ip])) + ip = ip + 1 + + # Check for end of list. + if (Memc[ip] == EOS || Memc[ip] == '\n') + return (EOF) + + op = 1 + for (ch=Memc[ip]; ch != EOS && !IS_WHITE(ch); ch=Memc[ip]) { + if (ch == ',' || ch == ':' || ch == ';') + break + else { + outstr[op] = ch + op = op + 1 + } + ip = ip + 1 + } + + delim = ch + if (delim != EOS) + ip = ip + 1 + + outstr[op] = EOS + return (op - 1) +end + + +# IKI_DEBUG -- Print debug information on the IKI internal data structures. + +procedure iki_debug (str, fd, flags) + +char str[ARB] #I title string +int fd #I output file +int flags #I (not used) + +int i +include "iki.com" + +begin + # Print global variables. + call fprintf (fd, "%s nkernels=%d sbufused=%d deftype=%d ") + call pargstr (str) + call pargi (k_nkernels) + call pargi (k_sbufused) + call pargi (k_defimtype) + call fprintf (fd, "inherit=%d nextn=%d\n") + call pargi (k_inherit) + call pargi (k_nextn) + + # List the installed kernels. + call fprintf (fd, "installed kernels ") + do i = 1, k_nkernels { + call fprintf (fd, "%s=%d ") + call pargstr (k_kname[1,i]) + call pargi (i) + } + call fprintf (fd, "\n") + + # Print the extension table. + do i = 1, k_nextn { + call fprintf (fd, "%6s %d (%s) %s\n") + call pargstr (k_sbuf[k_extn[i]]) + call pargi (k_kernel[i]) + call pargstr (k_kname[1,k_kernel[i]]) + call pargstr (k_sbuf[k_pattern[i]]) + } + + call flush (fd) +end diff --git a/sys/imio/iki/ikiinit.x b/sys/imio/iki/ikiinit.x new file mode 100644 index 00000000..41de76b6 --- /dev/null +++ b/sys/imio/iki/ikiinit.x @@ -0,0 +1,58 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "iki.h" + +# IKI_INIT -- Initialize the IKI kernel table, i.e., load all the standard +# kernels into the table. Additional kernels may be dynamically added at +# run time for special applications. + +procedure iki_init() + +extern oif_open(), oif_close(), oif_opix(), oif_updhdr(), + oif_access(), oif_copy(), oif_delete(), oif_rename() +extern fxf_open(), fxf_close(), fxf_opix(), fxf_updhdr(), + fxf_access(), fxf_copy(), fxf_delete(), fxf_rename() +extern plf_open(), plf_close(), plf_null(), plf_updhdr(), + plf_access(), plf_copy(), plf_delete(), plf_rename() +extern qpf_open(), qpf_close(), qpf_opix(), qpf_updhdr(), + qpf_access(), qpf_copy(), qpf_delete(), qpf_rename() +extern stf_open(), stf_close(), stf_opix(), stf_updhdr(), + stf_access(), stf_copy(), stf_delete(), stf_rname() + +bool first_time +data first_time /true/ +int iki_extninit() +include "iki.com" + +begin + if (!first_time) + return + + k_nkernels = 0 + + # Load the original IRAF format (OIF) kernel. + call iki_lddriver ("oif", oif_open, oif_close, oif_opix, oif_updhdr, + oif_access, oif_copy, oif_delete, oif_rename, 0) + + # Load the FITS image kernel (FXF). + call iki_lddriver ("fxf", fxf_open, fxf_close, fxf_opix, fxf_updhdr, + fxf_access, fxf_copy, fxf_delete, fxf_rename, 0) + + # Load the PLIO mask image mini-kernel (PLF - not a full kernel). + call iki_lddriver ("plf", plf_open, plf_close, plf_null, plf_updhdr, + plf_access, plf_copy, plf_delete, plf_rename, 0) + + # Load the QPOE photon image kernel (QPF). + call iki_lddriver ("qpf", qpf_open, qpf_close, qpf_opix, qpf_updhdr, + qpf_access, qpf_copy, qpf_delete, qpf_rename, IKF_NOCREATE) + + # Load the SDAS GEIS format (STF) kernel. + call iki_lddriver ("stf", stf_open, stf_close, stf_opix, stf_updhdr, + stf_access, stf_copy, stf_delete, stf_rname, 0) + + # Initialize the extension-based image typing mechanism. + if (iki_extninit (ENV_IMTYPE, DEF_IMTYPE, ENV_IMEXTN, DEF_IMEXTN) < 0) + ; + + first_time = false +end diff --git a/sys/imio/iki/ikildd.x b/sys/imio/iki/ikildd.x new file mode 100644 index 00000000..256e7e70 --- /dev/null +++ b/sys/imio/iki/ikildd.x @@ -0,0 +1,38 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include "iki.h" + +# IKI_LDDRIVER -- Load an IKI kernel into the kernel table, i.e., make a new +# kernel entry in the table containing the entry point address of each of the +# kernel procedures. + +procedure iki_lddriver (kname, ex_open, ex_close, ex_opix, ex_updhdr, + ex_access, ex_copy, ex_delete, ex_rename, flags) + +char kname[ARB] +extern ex_open(), ex_close(), ex_opix(), ex_updhdr() +extern ex_access(), ex_copy(), ex_delete(), ex_rename() +int locpr() +int flags + +include "iki.com" +errchk syserr + +begin + if (k_nkernels + 1 > MAX_KERNELS) + call syserr (SYS_IKIKTBLOVFL) + else + k_nkernels = k_nkernels + 1 + + call strcpy (kname, IKI_KNAME(k_nkernels), SZ_KNAME) + IKI_OPEN(k_nkernels) = locpr (ex_open) + IKI_CLOSE(k_nkernels) = locpr (ex_close) + IKI_OPIX(k_nkernels) = locpr (ex_opix) + IKI_UPDHDR(k_nkernels) = locpr (ex_updhdr) + IKI_ACCESS(k_nkernels) = locpr (ex_access) + IKI_COPY(k_nkernels) = locpr (ex_copy) + IKI_DELETE(k_nkernels) = locpr (ex_delete) + IKI_RENAME(k_nkernels) = locpr (ex_rename) + IKI_FLAGS(k_nkernels) = flags +end diff --git a/sys/imio/iki/ikimkfn.x b/sys/imio/iki/ikimkfn.x new file mode 100644 index 00000000..a224f728 --- /dev/null +++ b/sys/imio/iki/ikimkfn.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "iki.h" + +# IKI_MKFNAME -- Manufacture a filename from the root and extension fields +# given. + +procedure iki_mkfname (root, extn, fname, maxch) + +char root[ARB] #I root filename +char extn[ARB] #I filename extension +char fname[maxch] #O output filename +int maxch #I max chars out + +int op +int gstrcpy() +bool fnullfile() + +begin + op = gstrcpy (root, fname, maxch) + 1 + if (extn[1] != EOS && !fnullfile (root)) { + fname[op] = '.' + op = op + 1 + call strcpy (extn, fname[op], maxch-op+1) + } +end diff --git a/sys/imio/iki/ikiopen.x b/sys/imio/iki/ikiopen.x new file mode 100644 index 00000000..f60a672d --- /dev/null +++ b/sys/imio/iki/ikiopen.x @@ -0,0 +1,153 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include <imio.h> +include "iki.h" + +# IKI_OPEN -- Open or create an image. If opening an existing image, determine +# the type of image and open it with the corresponding kernel. If creating a +# new image, the value of the environment variable IMTYPE determines the type +# of image to be created, i.e., the kernel to be used to open the image. If +# opening a new copy image, create an image of the same type as the existing +# image. + +procedure iki_open (n_im, image, ksection, cl_index, cl_size, acmode, o_im) + +pointer n_im #I descriptor of new image (to be filled in) +char image[ARB] #I name of image or cl_index to be opened +char ksection[ARB] #I information to be passed on to kernel +int cl_index #I index of image within cl_index +int cl_size #I number of images in cl_index +int acmode #I access mode +pointer o_im #I existing image descriptor, if new_copy + +bool inherit +pointer sp, root, extn, textn, fextn +int status, clmode, i, k +errchk syserrs, zcalla +include "iki.com" + +begin + call smark (sp) + call salloc (root, SZ_PATHNAME, TY_CHAR) + call salloc (extn, MAX_LENEXTN, TY_CHAR) + call salloc (textn, MAX_LENEXTN, TY_CHAR) + call salloc (fextn, MAX_LENEXTN, TY_CHAR) + + # Compute the access mode for the ACCESS test, below. If opening an + # existing image, all we want to do here is test for the existence of + # the image. If opening a new image, use new image mode. + + if ((acmode == NEW_IMAGE || acmode == NEW_COPY)) + clmode = NEW_IMAGE + else + clmode = 0 + + # Parse the image name into the root and extn fields. + call iki_parse (image, Memc[root], Memc[extn]) + + # If we are opening a new image and an explicit extension is given + # this determines the type of image to be created. Otherwise if we + # are opening a new copy image and type inheritance is enabled, the + # new image will be the same type as the old one. Otherwise (new + # image, type not specified or inherited) the default image type + # specified by the IMTYPE mechanism is used. If opening an existing + # image the access method of each image kernel is called until a + # kernel recognizes the image. + + repeat { + # Is type inheritance permitted? + inherit = (k_inherit == YES) + if (inherit && acmode == NEW_COPY) + inherit = (and (IKI_FLAGS(IM_KERNEL(o_im)), IKF_NOCREATE) == 0) + + # Select the kernel to be used. + if (acmode == NEW_COPY && Memc[extn] == EOS && inherit) { + # Inherit the same type as an existing image. + k = IM_KERNEL(o_im) + break + + } else if (clmode == NEW_IMAGE && Memc[extn] == EOS) { + # Use the default type for new images. + k = k_defimtype + break + + } else { + # Select an image kernel by calling the access function in each + # loaded kernel until somebody claims the image. In the case + # of a new image, the access function tests only the legality + # of the extn. If no extn is given but the imagefile has an + # extension, the access procedure will fill in the extn field. + + k = 0 + for (i=1; i <= k_nkernels; i=i+1) { + call strcpy (Memc[extn], Memc[textn], MAX_LENEXTN) + call zcall5 (IKI_ACCESS(i), i, Memc[root], Memc[textn], + clmode, status) + + if (status == YES) { + if (k == 0) { + # Stop on the first match if an explicit extension + # was given. + + k = i + call strcpy (Memc[textn], Memc[fextn], MAX_LENEXTN) + if (Memc[extn] != EOS) + break + + } else if (Memc[extn] == EOS) { + # If no extension was given and we match multiple + # files then we have an ambiguous name and k=ERR. + + k = ERR + break + } + } + } + + # Update the selected extn field. + if (k > 0) + call strcpy (Memc[fextn], Memc[extn], MAX_LENEXTN) + + # If the search failed and an extension was given, maybe what + # we thought was an extension was really just part of the root + # filename. Try again with the extn folded into the root. + + if (k == 0 && Memc[extn] != EOS) { + call strcpy (image, Memc[root], SZ_PATHNAME) + Memc[extn] = EOS + } else + break + } + } + + # The image name is ambiguous; we don't know which image to open. + # This can only happen when opening an existing image and multiple + # images exist matching the name given. It is permissible to create + # multiple images with the same name but different types. + + if (k == ERR) + call syserrs (SYS_IKIAMBIG, IM_NAME(n_im)) + + # Illegal image type or image does not exist. + if (k == 0) { + if (acmode == NEW_IMAGE || acmode == NEW_COPY) + call syserrs (SYS_IKIEXTN, IM_NAME(n_im)) + else + call syserrs (SYS_IKIOPEN, IM_NAME(n_im)) + } + + # Set the image kernel (format) to be used. + IM_KERNEL(n_im) = k + + # Open/create the image. Save the kernel index in the image header + # so that subsequent IKI routines know which kernel to use. + + call zcalla (IKI_OPEN(k), k, n_im, o_im, Memc[root], Memc[extn], + ksection, cl_index, cl_size, acmode, status) + if (status == ERR) + call syserrs (SYS_IKIOPEN, IM_NAME(n_im)) + + call sfree (sp) +end diff --git a/sys/imio/iki/ikiopix.x b/sys/imio/iki/ikiopix.x new file mode 100644 index 00000000..33b3a9bc --- /dev/null +++ b/sys/imio/iki/ikiopix.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include <imio.h> +include "iki.h" + +# IKI_OPIX -- Open or create the pixel storage file, if any. We are called by +# IMIO when i/o is first done to the image. In the case of a new image, IMIO +# will already have set up the IM_NDIM and IM_LEN fields of the image header. + +procedure iki_opix (im) + +pointer im #I image descriptor +int status +include "iki.com" + +begin + iferr (call zcall2 (IKI_OPIX(IM_KERNEL(im)), im, status)) + status = ERR + if (status == ERR) + call syserrs (SYS_IKIOPIX, IM_NAME(im)) +end diff --git a/sys/imio/iki/ikiparse.x b/sys/imio/iki/ikiparse.x new file mode 100644 index 00000000..3ffb7d6c --- /dev/null +++ b/sys/imio/iki/ikiparse.x @@ -0,0 +1,85 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "iki.h" + +# IKI_PARSE -- Parse an image name into the root pathname and filename +# extension, if any. Only the known image type extensions are recognized +# as extensions, hence this routine cannot be used to parse general filenames. + +procedure iki_parse (image, root, extn) + +char image[ARB] #I input image name +char root[SZ_PATHNAME] #U output root pathname +char extn[MAX_LENEXTN] #O output extension + +pointer sp, imname +int ip, op, dot +int strlen(), iki_validextn() +bool streq() + +begin + call smark (sp) + call salloc (imname, SZ_PATHNAME, TY_CHAR) + + dot = 0 + op = 1 + + # The following is a backwards-compatibility kludge. If the image + # name we are given is the canonical standard test image STD_TESTIMAGE + # ("dev$pix") replace the name with the fully qualified name + # DEF_TESTIMAGE. This is necessary to avoid ambiguous image name + # errors due to pix.imh and pix.hhh being in the same directory; these + # are well known names, neither of which can easily be changed. + + if (streq (image, STD_TESTIMAGE)) + call strcpy (DEF_TESTIMAGE, Memc[imname], SZ_PATHNAME) + else + call strcpy (image, Memc[imname], SZ_PATHNAME) + + # Copy image name to root and mark the position of the last dot. + for (ip=1; Memc[imname+ip-1] != EOS; ip=ip+1) { + root[op] = Memc[imname+ip-1] + if (root[op] == '.') + dot = op + op = op + 1 + } + + root[op] = EOS + extn[1] = EOS + + # Reject . delimited fields longer than the maximum extension length. + if (op - dot - 1 > MAX_LENEXTN) + dot = NULL + + # If found extension, chop the root and fill in the extn field. + # If no extension found, we are all done. + + if (dot == NULL) { + call sfree (sp) + return + } else { + root[dot] = EOS + call strcpy (root[dot+1], extn, MAX_LENEXTN) + } + + # Search the list of legal imagefile extensions. If the extension + # given is not found in the list, tack it back onto the root and + # return a null extension. This is necessary if we are to allow + # dot delimited fields within image names without requiring the + # user to supply the image type extension. For example, "im.c" + # and "im.c.imh" must refer to the same image - ".c" is part of + # the image name, not an image type extension. + + if (strlen(extn) >= MIN_LENEXTN) + if (iki_validextn (0, extn) > 0) { + call sfree (sp) + return + } + + # Not a legal image header extension. Restore the extn field to the + # root and null the extn. + + root[dot] = '.' + extn[1] = EOS + call sfree (sp) +end diff --git a/sys/imio/iki/ikirename.x b/sys/imio/iki/ikirename.x new file mode 100644 index 00000000..cdeff731 --- /dev/null +++ b/sys/imio/iki/ikirename.x @@ -0,0 +1,74 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include "iki.h" + +# IKI_RENAME -- Rename an entire image or group of images. + +procedure iki_rename (old, new) + +char old[ARB] #I old name of image +char new[ARB] #I new name of image + +int k, n, status +pointer new_root, new_extn +pointer sp, old_root, old_extn + +bool streq() +int iki_access() +errchk syserrs +include "iki.com" + +begin + call smark (sp) + call salloc (old_root, SZ_PATHNAME, TY_CHAR) + call salloc (old_extn, MAX_LENEXTN, TY_CHAR) + call salloc (new_root, SZ_PATHNAME, TY_CHAR) + call salloc (new_extn, MAX_LENEXTN, TY_CHAR) + + # Verify that the old image exists and determine its type. + k = iki_access (old, Memc[old_root], Memc[old_extn], 0) + if (k < 0) + call syserrs (SYS_IKIAMBIG, old) + else if (k == 0) + call syserrs (SYS_IKIIMNF, old) + + # Determine if the old image exists. New name is new root plus + # legal extn for old image. + + n = iki_access (new, Memc[new_root], Memc[new_extn], 0) + if (n <= 0) + call iki_parse (new, Memc[new_root], Memc[new_extn]) + + # If an extension was given for the new image, verify that it is a + # valid extension for an image of the same type as the old image. + # We cannot change the image type in a rename operation. + + if (Memc[new_extn] != EOS) { + call zcall5 (IKI_ACCESS(k), k, Memc[new_root], Memc[new_extn], + NEW_FILE, status) + if (status == NO) + call strcpy (Memc[old_extn], Memc[new_extn], MAX_LENEXTN) + } else + call strcpy (Memc[old_extn], Memc[new_extn], MAX_LENEXTN) + + # Make sure we will not be clobbering an existing image. Renaming + # an image onto itself is ok; what it means to do this is up to + # the specific image kernel. + + if (n > 0) { + if (streq (Memc[old_root], Memc[new_root]) && + streq (Memc[old_extn], Memc[new_extn])) + ; # rename x -> x; let kernel decide what to do + else + call syserrs (SYS_IKICLOB, new) + } + + # Rename the image. + call zcall6 (IKI_RENAME(k), k, Memc[old_root], Memc[old_extn], + Memc[new_root], Memc[new_extn], status) + if (status == ERR) + call syserrs (SYS_IKIRENAME, old) + + call sfree (sp) +end diff --git a/sys/imio/iki/ikiupdhdr.x b/sys/imio/iki/ikiupdhdr.x new file mode 100644 index 00000000..f7ad22b8 --- /dev/null +++ b/sys/imio/iki/ikiupdhdr.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include <imio.h> +include "iki.h" + +# IKI_UPDHDR -- Update the image header. + +procedure iki_updhdr (im) + +pointer im #I image descriptor + +int status +include "iki.com" + +begin + iferr (call zcall2 (IKI_UPDHDR(IM_KERNEL(im)), im, status)) + status = ERR + if (status == ERR) + call syserrs (SYS_IKIUPDHDR, IM_NAME(im)) +end diff --git a/sys/imio/iki/mkpkg b/sys/imio/iki/mkpkg new file mode 100644 index 00000000..cd8663e9 --- /dev/null +++ b/sys/imio/iki/mkpkg @@ -0,0 +1,28 @@ +# Make the Image Kernel Interface. + +$checkout libex.a lib$ +$update libex.a +$checkin libex.a lib$ +$exit + +libex.a: + @oif # Original IRAF format + @fxf # FITS extension format + @plf # PLIO mask image mini-kernel (partial) + @qpf # QPOE photon image kernel + @stf # ST SDAS/GEIS format + + ikiaccess.x iki.com iki.h <imhdr.h> + ikiclose.x iki.com iki.h <imhdr.h> <imio.h> + ikicopy.x iki.com iki.h + ikidelete.x iki.com iki.h + ikiextn.x iki.com iki.h <ctype.h> <imhdr.h> + ikiinit.x iki.com iki.h + ikildd.x iki.com iki.h + ikimkfn.x iki.h + ikiopen.x iki.com iki.h <imhdr.h> <imio.h> + ikiopix.x iki.com iki.h <imhdr.h> <imio.h> + ikiparse.x iki.h + ikirename.x iki.com iki.h + ikiupdhdr.x iki.com <imio.h> iki.h <imhdr.h> + ; diff --git a/sys/imio/iki/oif/README b/sys/imio/iki/oif/README new file mode 100644 index 00000000..01e30678 --- /dev/null +++ b/sys/imio/iki/oif/README @@ -0,0 +1 @@ +IKI/OIF -- IKI kernel for the old (original) IRAF image format. diff --git a/sys/imio/iki/oif/imhv1.h b/sys/imio/iki/oif/imhv1.h new file mode 100644 index 00000000..a9a37874 --- /dev/null +++ b/sys/imio/iki/oif/imhv1.h @@ -0,0 +1,75 @@ +# IMHV1.H -- Version 1 of the OIF binary file header (April 1988). + +define V1_MAGIC "imhdr" # file identification tag +define V1_PMAGIC "impix" # file identification tag +define V1_VERSION 1 # header version number + +define SZ_V1IMPIXFILE 79 # name of pixel storage file +define SZ_V1IMHDRFILE 79 # name of header storage file +define SZ_V1IMTITLE 79 # image title string +define SZ_V1IMHIST 511 # image history record +define SZ_V1BUNIT 9 # brightness units string +define SZ_V1CTYPE 9 # coord axes units string + +# The IMIO image header structure. + +# Parameters. +define LEN_V1IMHDR 513 # length of std header +define LEN_V1PIXHDR 183 # length of pixel file header +define V1U LEN_V1IMHDR # offset to user fields +define IM_V1USERAREA (P2C($1+V1U)) # user area (database) + +# Disk resident header. +define IM_V1MAGIC Memi[$1] # contains the string "imhdr" +define IM_V1HDRLEN Memi[$1+3] # length of image header +define IM_V1PIXTYPE Memi[$1+4] # datatype of the pixels +define IM_V1NDIM Memi[$1+5] # number of dimensions +define IM_V1LEN Meml[$1+$2+6-1] # length of the dimensions +define IM_V1PHYSLEN Meml[$1+$2+13-1] # physical length (as stored) +define IM_V1SSMTYPE Meml[$1+20] # type of subscript mapping +define IM_V1LUTOFF Meml[$1+21] # offset to subscript map luts +define IM_V1PIXOFF Meml[$1+22] # offset of the pixels +define IM_V1HGMOFF Meml[$1+23] # offset of hgm pixels +define IM_V1BLIST Meml[$1+24] # offset of bad pixel list +define IM_V1SZBLIST Meml[$1+25] # size of bad pixel list +define IM_V1NBPIX Meml[$1+26] # number of bad pixels +define IM_V1CTIME Meml[$1+27] # time of image creation +define IM_V1MTIME Meml[$1+28] # time of last modify +define IM_V1LIMTIME Meml[$1+29] # time min,max computed +define IM_V1MAX Memr[P2R($1+30)] # max pixel value +define IM_V1MIN Memr[P2R($1+31)] # min pixel value +define IM_V1HGM ($1+33) # histogram descriptor +define IM_V1CTRAN ($1+52) # coordinate transformations +define IM_V1PIXFILE Memc[P2C($1+103)] # name of pixel storage file +define IM_V1HDRFILE Memc[P2C($1+143)] # name of header storage file +define IM_V1TITLE Memc[P2C($1+183)] # image name string +define IM_V1HISTORY Memc[P2C($1+223)] # history comment string + +# The Histogram structure (field IM_HGM) +define LEN_HGMSTRUCT 20 +define HGM_TIME Meml[$1] # time when hgm was computed +define HGM_LEN Meml[$1+1] # number of bins in hgm +define HGM_NPIX Meml[$1+2] # npix used to compute hgm +define HGM_MIN Memr[P2R($1+3)] # min hgm value +define HGM_MAX Memr[P2R($1+4)] # max hgm value +define HGM_INTEGRAL Memr[P2R($1+5)] # integral of hgm +define HGM_MEAN Memr[P2R($1+6)] # mean value +define HGM_VARIANCE Memr[P2R($1+7)] # variance about mean +define HGM_SKEWNESS Memr[P2R($1+8)] # skewness of hgm +define HGM_MODE Memr[P2R($1+9)] # modal value of hgm +define HGM_LCUT Memr[P2R($1+10)] # low cutoff value +define HGM_HCUT Memr[P2R($1+11)] # high cutoff value +# next available field: ($1+12) + +# The Coordinate Transformation Structure (IM_CTRAN) +define LEN_CTSTRUCT 50 +define CT_VALID Memi[$1] # (y/n) is structure valid? +define CT_BSCALE Memr[P2R($1+1)] # pixval scale factor +define CT_BZERO Memr[P2R($1+2)] # pixval offset +define CT_CRVAL Memr[P2R($1+$2+3-1)] # value at pixel +define CT_CRPIX Memr[P2R($1+$2+10-1)] # index of pixel +define CT_CDELT Memr[P2R($1+$2+17-1)] # increment along axis +define CT_CROTA Memr[P2R($1+$2+24-1)] # rotation angle +define CT_BUNIT Memc[P2C($1+31)] # pixval ("brightness") units +define CT_CTYPE Memc[P2C($1+36)] # coord units string +# next available field: ($1+41) diff --git a/sys/imio/iki/oif/imhv2.h b/sys/imio/iki/oif/imhv2.h new file mode 100644 index 00000000..d7eaa1f7 --- /dev/null +++ b/sys/imio/iki/oif/imhv2.h @@ -0,0 +1,43 @@ +# IMHV2.H -- Version 2 of the OIF binary file header (March 1997). + +define V2_MAGIC "imhv2" # file identification tag +define V2_PMAGIC "impv2" # file identification tag +define V2_VERSION 2 # header version + +define SZ_V2IMPIXFILE 255 # name of pixel storage file +define SZ_V2IMHDRFILE 255 # name of header storage file +define SZ_V2IMTITLE 383 # image title string +define SZ_V2IMHIST 1023 # image history record + +# The IMIO image header structure. + +# Parameters. +define LEN_V2IMHDR 1024 # length of std header +define LEN_V2PIXHDR 293 # length of pixel file header +define V2U LEN_V2IMHDR # offset to user fields +define IM_V2USERAREA (P2C($1+V2U)) # user area (database) + +# Disk resident header. +define IM_V2MAGIC Memi[$1] # contains the string "imhdr" +define IM_V2HDRLEN Memi[$1+3] # length of image header +define IM_V2PIXTYPE Memi[$1+4] # datatype of the pixels +define IM_V2SWAPPED Memi[$1+5] # pixels are byte swapped +define IM_V2NDIM Memi[$1+6] # number of dimensions +define IM_V2LEN Meml[$1+$2+7-1] # length of the dimensions +define IM_V2PHYSLEN Meml[$1+$2+14-1] # physical length (as stored) +define IM_V2SSMTYPE Meml[$1+21] # type of subscript mapping +define IM_V2LUTOFF Meml[$1+22] # offset to subscript map luts +define IM_V2PIXOFF Meml[$1+23] # offset of the pixels +define IM_V2HGMOFF Meml[$1+24] # offset of hgm pixels +define IM_V2BLIST Meml[$1+25] # offset of bad pixel list +define IM_V2SZBLIST Meml[$1+26] # size of bad pixel list +define IM_V2NBPIX Meml[$1+27] # number of bad pixels +define IM_V2CTIME Meml[$1+28] # time of image creation +define IM_V2MTIME Meml[$1+29] # time of last modify +define IM_V2LIMTIME Meml[$1+30] # time min,max computed +define IM_V2MAX Memr[P2R($1+31)] # max pixel value +define IM_V2MIN Memr[P2R($1+32)] # min pixel value +define IM_V2PIXFILE Memc[P2C($1+37)] # name of pixel storage file +define IM_V2HDRFILE Memc[P2C($1+165)] # name of header storage file +define IM_V2TITLE Memc[P2C($1+293)] # image name string +define IM_V2HISTORY Memc[P2C($1+485)] # history comment string diff --git a/sys/imio/iki/oif/mkpkg b/sys/imio/iki/oif/mkpkg new file mode 100644 index 00000000..81a4d57e --- /dev/null +++ b/sys/imio/iki/oif/mkpkg @@ -0,0 +1,21 @@ +# Make the IKI/OIF interface (Old IRAF Format images) + +$checkout libex.a lib$ +$update libex.a +$checkin libex.a lib$ +$exit + +libex.a: + oifaccess.x oif.h + oifclose.x <error.h> <imhdr.h> <imio.h> <protect.h> + oifcopy.x oif.h + oifdelete.x <error.h> <imhdr.h> <protect.h> + oifgpfn.x oif.h <knet.h> + oifmkpfn.x oif.h <imhdr.h> <imio.h> <knet.h> + oifopen.x oif.h <imhdr.h> <imio.h> <fio.h> <error.h> + oifopix.x oif.h <config.h> <imhdr.h> <imio.h> + oifrdhdr.x imhv1.h imhv2.h oif.h <imhdr.h> <imio.h> <mach.h> + oifrename.x oif.h <error.h> <imhdr.h> <imio.h> + oifupdhdr.x oif.h <error.h> <imhdr.h> <imio.h> + oifwrhdr.x imhv1.h imhv2.h oif.h <imhdr.h> <imio.h> <mach.h> + ; diff --git a/sys/imio/iki/oif/oif.h b/sys/imio/iki/oif/oif.h new file mode 100644 index 00000000..d1161659 --- /dev/null +++ b/sys/imio/iki/oif/oif.h @@ -0,0 +1,15 @@ +# OIF.H -- IKI/OIF internal definitions. + +define MAX_LENEXTN 3 # max length imagefile extension +define OIF_HDREXTN "imh" # image header filename extension +define OIF_PIXEXTN "pix" # image pixfile extension +define LEN_PIXHDR 512 # max length of PIXHDR structure +define COMPRESS NO # disable alignment of image lines? +define DEF_VERSION 2 # default file version + +define ENV_OIFVER "oifversion" # default format for new images +define HDR "HDR$" # stands for header directory +define STRLEN_HDR 4 + +define TY_IMHDR 1 # main imagefile header +define TY_PIXHDR 2 # pixel file header diff --git a/sys/imio/iki/oif/oifaccess.x b/sys/imio/iki/oif/oifaccess.x new file mode 100644 index 00000000..e5dfe28a --- /dev/null +++ b/sys/imio/iki/oif/oifaccess.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "oif.h" + +# OIF_ACCESS -- Test the accessibility or existence of an existing image, or +# the legality of the name of a new image. + +procedure oif_access (kernel, root, extn, acmode, status) + +int kernel #I IKI kernel +char root[ARB] #I root filename +char extn[ARB] #U extension (SET on output if none specified) +int acmode #I access mode (0 to test only existence) +int status #O status + +pointer sp, fname +int btoi(), access(), iki_validextn() +string oif_extn OIF_HDREXTN +bool strne() + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + + # If new image, test only the legality of the given extension. + # This is used to select a kernel given the imagefile extension. + + if (acmode == NEW_IMAGE || acmode == NEW_COPY) { + status = btoi (iki_validextn (kernel, extn) > 0) + call sfree (sp) + return + } + + # Reject image if an invalid extension is given. + if (extn[1] != EOS && strne (extn, oif_extn)) { + status = NO + call sfree (sp) + return + } + + # Check for the imagefile. + call iki_mkfname (root, oif_extn, Memc[fname], SZ_PATHNAME) + if (access (Memc[fname], acmode, 0) == YES) { + if (extn[1] == EOS) + call strcpy (oif_extn, extn, MAX_LENEXTN) + status = YES + } else + status = NO + + call sfree (sp) +end diff --git a/sys/imio/iki/oif/oifclose.x b/sys/imio/iki/oif/oifclose.x new file mode 100644 index 00000000..8eb58b4f --- /dev/null +++ b/sys/imio/iki/oif/oifclose.x @@ -0,0 +1,36 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <protect.h> +include <error.h> +include <imhdr.h> +include <imio.h> + +# OIF_CLOSE -- Close an OIF format image. There is little for us to do, since +# IMIO will already have updated the header if necessary and flushed any pixel +# output. Neither do we have to deallocate the IMIO descriptor, since it was +# allocated by IMIO. + +procedure oif_close (im, status) + +pointer im # image descriptor +int status + +int junk +int protect() + +begin + # Close the pixel file and header file, if open. + if (IM_PFD(im) != NULL) + call close (IM_PFD(im)) + if (IM_HFD(im) != NULL) + call close (IM_HFD(im)) + + # If we are closing a new image, set delete protection on the + # header file to prevent the user from using DELETE to delete + # the image header file, which would leave a headerless pixel + # storage file lying about somewhere. + + if (IM_ACMODE(im) == NEW_IMAGE || IM_ACMODE(im) == NEW_COPY) + iferr (junk = protect (IM_HDRFILE(im), SET_PROTECTION)) + call erract (EA_WARN) +end diff --git a/sys/imio/iki/oif/oifcopy.x b/sys/imio/iki/oif/oifcopy.x new file mode 100644 index 00000000..8a7ea41d --- /dev/null +++ b/sys/imio/iki/oif/oifcopy.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "oif.h" + +# OIF_COPY -- Copy an image. A special operator is provided for fast, blind +# copies of entire images. + +procedure oif_copy (kernel, old_root, old_extn, new_root, new_extn, status) + +int kernel #I IKI kernel +char old_root[ARB] # old image root name +char old_extn[ARB] # old image extn +char new_root[ARB] # new image root name +char new_extn[ARB] # new extn +int status + +pointer sp +pointer old_fname, new_fname + +begin + call smark (sp) + call salloc (old_fname, SZ_PATHNAME, TY_CHAR) + call salloc (new_fname, SZ_PATHNAME, TY_CHAR) + + # Get filename of old and new images. + call iki_mkfname (old_root, old_extn, Memc[old_fname], SZ_PATHNAME) + call iki_mkfname (new_root, OIF_HDREXTN, Memc[new_fname], SZ_PATHNAME) + + # For now, this is stubbed out. + status = ERR + call sfree (sp) +end diff --git a/sys/imio/iki/oif/oifdelete.x b/sys/imio/iki/oif/oifdelete.x new file mode 100644 index 00000000..758309a7 --- /dev/null +++ b/sys/imio/iki/oif/oifdelete.x @@ -0,0 +1,53 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <protect.h> +include <error.h> +include <imhdr.h> + +# OIF_DELETE -- Delete an image. A special operator is required since the +# image is stored as two files. + +procedure oif_delete (kernel, root, extn, status) + +int kernel #I IKI kernel +char root[ARB] #I root filename +char extn[ARB] #U extension +int status + +int junk +pointer sp, fname, pixfile +int access(), protect() +pointer im, immapz() + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + call salloc (pixfile, SZ_PATHNAME, TY_CHAR) + + # Generate filename. + call iki_mkfname (root, extn, Memc[fname], SZ_PATHNAME) + + iferr (im = immapz (Memc[fname], READ_ONLY, 0)) { + call erract (EA_WARN) + + } else { + if (IM_PIXFILE(im) != EOS) { + call oif_gpixfname (IM_PIXFILE(im), IM_HDRFILE(im), + Memc[pixfile], SZ_PATHNAME) + if (access (Memc[pixfile],0,0) == YES) + iferr (call delete (Memc[pixfile])) + call erract (EA_WARN) + } + + call imunmap (im) + + # Do not complain if the file is not protected. + iferr (junk = protect (Memc[fname], REMOVE_PROTECTION)) + ; + iferr (call delete (Memc[fname])) + call erract (EA_WARN) + } + + call sfree (sp) + status = OK +end diff --git a/sys/imio/iki/oif/oifgpfn.x b/sys/imio/iki/oif/oifgpfn.x new file mode 100644 index 00000000..cc9a7fef --- /dev/null +++ b/sys/imio/iki/oif/oifgpfn.x @@ -0,0 +1,60 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <knet.h> +include "oif.h" + +# OIF_GPIXFNAME -- Convert a logical pixfile name into a physical pathname. + +procedure oif_gpixfname (pixfile, hdrfile, path, maxch) + +char pixfile[ARB] # pixfile name +char hdrfile[ARB] # header file name (gives hdr directory) +char path[maxch] # receives pathname +int maxch + +int ip, nchars +pointer sp, fname, op +int strncmp(), fnldir() + +begin + # Merely return pathname if not case "HDR$". + if (strncmp (pixfile, HDR, STRLEN_HDR) != 0) { + call fpathname (pixfile, path, maxch) + return + } + + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + + # Get host pathname of pixel file directory. + nchars = fnldir (hdrfile, Memc[fname], SZ_PATHNAME) + call fpathname (Memc[fname], path, maxch) + + # Fold in any subdirectories from the pixfile name. + # (as in HDR$pixels/). + + op = fname + nchars = 0 + + for (ip=STRLEN_HDR+1; pixfile[ip] != EOS; ip=ip+1) { + if (pixfile[ip] == '/') { + Memc[op] = EOS + call zfsubd (path, maxch, Memc[fname], nchars) + op = fname + } else { + Memc[op] = pixfile[ip] + op = op + 1 + } + } + + # Tack on the pixel file name, which was left in the fname buf. + if (op > fname) { + Memc[op] = EOS + if (nchars > 0) + call strcpy (Memc[fname], path[nchars+1], maxch-nchars) + else + call strcat (Memc[fname], path, maxch) + } + + call sfree (sp) +end diff --git a/sys/imio/iki/oif/oifmkpfn.x b/sys/imio/iki/oif/oifmkpfn.x new file mode 100644 index 00000000..234fa706 --- /dev/null +++ b/sys/imio/iki/oif/oifmkpfn.x @@ -0,0 +1,118 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include <imio.h> +include <knet.h> +include "oif.h" + +# OIF_MKPIXFNAME -- Generate the pixel file name. Leave the logical pixfile +# name in the image header, and return the pathname to the pixel file in the +# output argument. + +procedure oif_mkpixfname (im, pixfile, maxch) + +pointer im # image descriptor +char pixfile[maxch] # receives pathname to pixfile +int maxch + +char suffix[2] +int len_osdir, len_root, len_extn, n +pointer sp, imdir, osdir, root, extn, subdir, fname, ip, op + +bool fnullfile() +int fnroot(), fnldir(), access(), envgets(), strncmp() +string pixextn OIF_PIXEXTN +errchk fmkdir, imerr + +begin + # Clear junk text at the end of the filename. + call aclrc (IM_PIXFILE(im), SZ_IMPIXFILE) + + # Check for the null image. + if (fnullfile (IM_HDRFILE(im))) { + call strcpy ("dev$null", IM_PIXFILE(im), SZ_IMPIXFILE) + call strcpy (IM_PIXFILE(im), pixfile, maxch) + return + } + + call smark (sp) + call salloc (imdir, SZ_PATHNAME, TY_CHAR) + call salloc (osdir, SZ_PATHNAME, TY_CHAR) + call salloc (root, SZ_PATHNAME, TY_CHAR) + call salloc (subdir, SZ_PATHNAME, TY_CHAR) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + call salloc (extn, SZ_FNAME, TY_CHAR) + + if (envgets ("imdir", Memc[imdir], SZ_PATHNAME) <= 0) + call strcpy (HDR, Memc[imdir], SZ_PATHNAME) + + if (strncmp (Memc[imdir], HDR, STRLEN_HDR) == 0) { + # Put pixfile in same directory as the header or in a subdirectory. + # In the latter case, create the directory if it does not already + # exist. + + ip = imdir + STRLEN_HDR + for (op=subdir; Memc[ip] != EOS && Memc[ip] != '/'; ip=ip+1) { + Memc[op] = Memc[ip] + op = op + 1 + } + Memc[op] = EOS + + if (Memc[subdir] != EOS) { + n = fnldir (IM_HDRFILE(im), Memc[fname], SZ_PATHNAME) + call fpathname (Memc[fname], Memc[fname], SZ_PATHNAME) + call zfsubd (Memc[fname], SZ_PATHNAME, Memc[subdir], n) + if (access (Memc[fname], 0, DIRECTORY_FILE) == NO) + call fmkdir (Memc[fname]) + } + } else + call fpathname (Memc[imdir], Memc[imdir], SZ_PATHNAME) + + # Make up the root name of the new pixel file. Take the root part of + # the header file and escape sequence encode it. We have to do this + # because it is to be concatenated to an OS directory name, which will + # prevent translation of the root file name during normal filename + # mapping. + + if (fnroot (IM_HDRFILE(im), Memc[fname], SZ_PATHNAME) <= 0) + call strcpy (pixextn, Memc[fname], SZ_PATHNAME) + call iki_mkfname (Memc[fname], pixextn, Memc[fname], SZ_PATHNAME) + call vfn_translate (Memc[fname], Memc[osdir], len_osdir, + Memc[root], len_root, Memc[extn], len_extn) + + suffix[1] = 'a' + suffix[2] = 'a' + suffix[3] = EOS + + for (n=0; ; n=n+1) { + call sprintf (IM_PIXFILE(im), SZ_PATHNAME, "%s%s.%s") + call pargstr (Memc[imdir]) + call pargstr (Memc[root]) + call pargstr (pixextn) + + call oif_gpixfname (IM_PIXFILE(im), IM_HDRFILE(im), pixfile, maxch) + + # Ensure that the filename is unique. + if (access (pixfile, 0,0) == YES) { + if (n == 0) { + for (op=root; Memc[op] != EOS; op=op+1) + ; + } else { + if (suffix[2] == 'z') { + suffix[2] = 'a' + if (suffix[1] == 'z') + call imerr (IM_NAME(im), SYS_FMKTEMP) + else + suffix[1] = suffix[1] + 1 + } else + suffix[2] = suffix[2] + 1 + } + + call strcpy (suffix, Memc[op], 2) + } else + break + } + + call sfree (sp) +end diff --git a/sys/imio/iki/oif/oifopen.x b/sys/imio/iki/oif/oifopen.x new file mode 100644 index 00000000..a280f163 --- /dev/null +++ b/sys/imio/iki/oif/oifopen.x @@ -0,0 +1,137 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <error.h> +include <imhdr.h> +include <imio.h> +include <fio.h> +include "oif.h" + +# OIF_OPEN -- Open/create an image. + +procedure oif_open (kernel, im, o_im, root, extn, ksection, cl_index, cl_size, acmode, status) + +int kernel #I IKI kernel +pointer im #I image descriptor +pointer o_im #I old image, if new_copy image +char root[ARB] #I root image name +char extn[ARB] #I extension, if any +char ksection[ARB] #I NOT USED +int cl_index #I NOT USED +int cl_size #I NOT USED +int acmode #I access mode +int status #O return value + +pointer sp, fname, pixfile +int hfd, nchars, mode, junk +int open(), oif_rdhdr(), access(), protect(), envgeti() +bool envgetb(), fnullfile() +errchk syserrs +define err_ 91 + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + call salloc (pixfile, SZ_PATHNAME, TY_CHAR) + + status = OK + + # The only valid cl_index is -1 (none specified) or 1. + if (!(cl_index < 0 || cl_index == 1)) + goto err_ + + # This kernel does not permit a kernel section to be used. + if (ksection[1] != EOS) + call syserrs (SYS_IKIKSECTNS, Memc[fname]) + + # Determine access mode for header file. + if (acmode == NEW_COPY || acmode == NEW_IMAGE) + mode = NEW_FILE + else + mode = acmode + + # Generate full header file name; the extension may be either ".imh" + # or nothing, and was set earlier by oif_access(). + + if (mode == NEW_FILE && extn[1] == EOS) + call iki_mkfname (root, OIF_HDREXTN, Memc[fname], SZ_PATHNAME) + else + call iki_mkfname (root, extn, Memc[fname], SZ_PATHNAME) + + # Delete any old image if one exists and imclobber is enabled. + if (mode == NEW_FILE && !fnullfile (Memc[fname]) && + (access (Memc[fname], 0,0) == YES)) { + + if (envgetb ("imclobber")) { + iferr (hfd = open (Memc[fname], READ_ONLY, BINARY_FILE)) { + status = ERR + goto err_ + } + nchars = LEN_IMHDR * SZ_MII_INT + if (oif_rdhdr (hfd, im, nchars, TY_IMHDR) < 0) { + status = ERR + goto err_ + } + if (IM_PIXFILE(im) != EOS) { + call oif_gpixfname (IM_PIXFILE(im), IM_HDRFILE(im), + Memc[pixfile], SZ_PATHNAME) + if (access (Memc[pixfile],0,0) == YES) + iferr (call delete (Memc[pixfile])) + call erract (EA_WARN) + } + call close (hfd) + iferr (junk = protect (Memc[fname], REMOVE_PROTECTION)) + ; + iferr (call delete (Memc[fname])) + call erract (EA_WARN) + } else + call syserrs (SYS_IKICLOB, Memc[fname]) + } + + # Open the image header file. + iferr (hfd = open (Memc[fname], mode, BINARY_FILE)) + goto err_ + + IM_HFD(im) = hfd + + # If opening an existing image, read the OIF fixed format binary + # image header into the image descriptor. If opening a new image, + # write out a generic image header so that the image can be accessed + # and deleted with imdelete should the operation be aborted before + # a full image is written. + + if (mode == NEW_FILE) { + iferr (IM_HDRVER(im) = envgeti (ENV_OIFVER)) + IM_HDRVER(im) = DEF_VERSION + call aclrc (IM_HDRFILE(im), SZ_IMHDRFILE) + call strcpy (Memc[fname], IM_HDRFILE(im), SZ_IMHDRFILE) + iferr (call oif_updhdr (im, status)) + ; + } else { + iferr { + nchars = (IM_LENHDRMEM(im) - LEN_IMHDR) * SZ_MII_INT + if (oif_rdhdr (hfd, im, nchars, TY_IMHDR) < 0) + status = ERR + else { + call aclrc (IM_HDRFILE(im), SZ_IMHDRFILE) + call strcpy (Memc[fname], IM_HDRFILE(im), SZ_IMHDRFILE) + } + } then + status = ERR + } + + # It is best to close the header file at this point for two reasons: + # to improve error recovery (if an abort occurs with a new file still + # open FIO will delete it) and to free file descriptors (important for + # applications that open many images). If the header needs to be + # updated, oif_updhdr will reopen the header file. + + call close (hfd) + IM_HFD(im) = NULL + + call sfree (sp) + return +err_ + status = ERR + call sfree (sp) +end diff --git a/sys/imio/iki/oif/oifopix.x b/sys/imio/iki/oif/oifopix.x new file mode 100644 index 00000000..c9652374 --- /dev/null +++ b/sys/imio/iki/oif/oifopix.x @@ -0,0 +1,103 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <config.h> +include <imhdr.h> +include <imio.h> +include "oif.h" + +# OIF_OPIX -- Open (or create) the pixel storage file. If the image header file +# is `image.imh' the associated pixel storage file will be `imdir$image.pix', +# or some variation thereon should a collision occur. The environment variable +# IMDIR controls where the pixfile will be placed. The following classes of +# values are provided: +# +# path Put pixfile in named absolute directory regardless of +# where the header file is. +# ./ Put pixfile in the current directory at image creation +# time (special case of previous case). +# HDR$ Put pixfile in the same directory as the header file. +# HDR$subdir/ Put pixfiles in the subdirectory `subdir' of the +# directory containing the header file. IMIO will +# create the subdirectory if necessary. + +procedure oif_opix (im, status) + +pointer im # image descriptor +int status # return status + +long pixoff +pointer sp, pixhdr, pixfile +int pfd, blklen + +int open(), fdevblk(), oif_rdhdr() +errchk open, falloc, fdevblk, imerr, oif_rdhdr, oif_updhdr +errchk imioff, oif_wrhdr, oif_mkpixfname, oif_gpixfname, flush + +begin + status = OK + if (IM_PFD(im) != NULL) + return + + + call smark (sp) + call salloc (pixhdr, LEN_IMDES + LEN_PIXHDR, TY_STRUCT) + call salloc (pixfile, SZ_PATHNAME, TY_CHAR) + + switch (IM_ACMODE(im)) { + case READ_ONLY, READ_WRITE, WRITE_ONLY, APPEND: + if (IM_PIXFILE(im) == EOS) + call imerr (IM_NAME(im), SYS_IMRDPIXFILE) + + call oif_gpixfname (IM_PIXFILE(im), IM_HDRFILE(im), Memc[pixfile], + SZ_PATHNAME) + pfd = open (Memc[pixfile], IM_ACMODE(im), STATIC_FILE) + + call seek (pfd, BOFL) + if (oif_rdhdr (pfd, pixhdr, 0, TY_PIXHDR) < 0) + call imerr (IM_NAME(im), SYS_IMRDPIXFILE) + + case NEW_COPY, NEW_FILE, TEMP_FILE: + # Generate the pixel file name. + call oif_mkpixfname (im, Memc[pixfile], SZ_PATHNAME) + + # Compute the offset to the pixels in the pixfile. Allow space + # for the pixhdr pixel storage file header and start the pixels + # on the next device block boundary. + + blklen = fdevblk (Memc[pixfile]) + pixoff = LEN_PIXHDR * SZ_MII_INT + call imalign (pixoff, blklen) + + # Call IMIO to initialize the physical dimensions of the image + # and the absolute file offsets of the major components of the + # pixel storage file. + + call imioff (im, pixoff, COMPRESS, blklen) + + # Open the new pixel storage file (preallocate space if + # enabled on local system). Save the physical pathname of + # the pixfile in the image header, in case "imdir$" changes. + + if (IM_FALLOC == YES) { + call falloc (Memc[pixfile], IM_HGMOFF(im) - 1) + pfd = open (Memc[pixfile], READ_WRITE, STATIC_FILE) + } else + pfd = open (Memc[pixfile], NEW_FILE, BINARY_FILE) + + # Write small header into pixel storage file. Allows detection of + # headerless pixfiles, and reconstruction of header if it gets lost. + + call oif_wrhdr (pfd, im, TY_PIXHDR) + call flush (pfd) + + # Update the image header so that it knows about the pixel file. + call oif_updhdr (im, status) + + default: + call imerr (IM_NAME(im), SYS_IMACMODE) + } + + IM_PFD(im) = pfd + call sfree (sp) +end diff --git a/sys/imio/iki/oif/oifrdhdr.x b/sys/imio/iki/oif/oifrdhdr.x new file mode 100644 index 00000000..b11601cb --- /dev/null +++ b/sys/imio/iki/oif/oifrdhdr.x @@ -0,0 +1,196 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> +include <imhdr.h> +include <imio.h> +include "imhv1.h" +include "imhv2.h" +include "oif.h" + + +# OIF_RDHDR -- Read the image header. Either the main image header or the +# pixel file header can be read. + +int procedure oif_rdhdr (fd, im, uchars, htype) + +int fd #I header file descriptor +pointer im #I image descriptor +int uchars #I maxchars of user area data to read +int htype #I TY_IMHDR or TY_PIXHDR + +pointer sp, v1 +char immagic[SZ_IMMAGIC] +int sulen_userarea, hdrlen, nchars, status + +bool streq() +int miireadc(), miireadi(), miireadl(), miireadr() +int btoi(), read() + +errchk read, miireadc, miireadi, miireadl, miireadr +define readerr_ 91 + +begin + # Determine the file type. + call seek (fd, BOFL) + if (read (fd, immagic, SZ_IMMAGIC) != SZ_IMMAGIC) + return (ERR) + + if (htype == TY_PIXHDR && streq (immagic, V1_PMAGIC)) { + # V1 Pixel file header. + return (OK) + + } else if (htype == TY_IMHDR && streq (immagic, V1_MAGIC)) { + # Old V1 image header. + + call smark (sp) + call salloc (v1, LEN_V1IMHDR, TY_STRUCT) + + call seek (fd, BOFL) + nchars = LEN_V1IMHDR * SZ_MII_INT + if (read (fd, IM_V1MAGIC(v1), nchars) != nchars) { + call sfree (sp) + return (ERR) + } + + # Initialize the output image header. + call strcpy (IMH_MAGICSTR, IM_MAGIC(im), SZ_IMMAGIC) + IM_HDRVER(im) = V1_VERSION + + # The following is the length of the user area in SU. + sulen_userarea = IM_V1HDRLEN(v1) - LEN_V1IMHDR + IM_HDRLEN(im) = LEN_IMHDR + sulen_userarea + + IM_SWAP(im) = NO + IM_SWAPPED(im) = -1 + IM_PIXTYPE(im) = IM_V1PIXTYPE(v1) + + IM_NDIM(im) = IM_V1NDIM(v1) + call amovl (IM_V1LEN(v1,1), IM_LEN(im,1), IM_MAXDIM) + call amovl (IM_V1PHYSLEN(v1,1), IM_PHYSLEN(im,1), IM_MAXDIM) + + IM_SSMTYPE(im) = IM_V1SSMTYPE(v1) + IM_LUTOFF(im) = IM_V1LUTOFF(v1) + IM_PIXOFF(im) = IM_V1PIXOFF(v1) + IM_HGMOFF(im) = IM_V1HGMOFF(v1) + IM_CTIME(im) = IM_V1CTIME(v1) + IM_MTIME(im) = IM_V1MTIME(v1) + IM_LIMTIME(im) = IM_V1LIMTIME(v1) + IM_MAX(im) = IM_V1MAX(v1) + IM_MIN(im) = IM_V1MIN(v1) + + call strcpy (IM_V1PIXFILE(v1), IM_PIXFILE(im), SZ_IMPIXFILE) + call strcpy (IM_V1HDRFILE(v1), IM_HDRFILE(im), SZ_IMHDRFILE) + call strcpy (IM_V1TITLE(v1), IM_TITLE(im), SZ_IMTITLE) + call strcpy (IM_V1HISTORY(v1), IM_HISTORY(im), SZ_IMHIST) + + # Read and output the user area. + if (uchars > 0 && sulen_userarea > 0) { + nchars = min (uchars, sulen_userarea * SZ_MII_INT) + if (read (fd, Memc[IM_USERAREA(im)], nchars) <= 0) + return (ERR) + } + + call sfree (sp) + return (OK) + } + + # Check for a new format header. + call seek (fd, BOFL) + if (miireadc (fd, immagic, SZ_IMMAGIC) < 0) + return (ERR) + + if (htype == TY_PIXHDR && streq (immagic, V2_PMAGIC)) { + # V2 Pixel file header. + return (OK) + + } else if (htype == TY_IMHDR && streq (immagic, V2_MAGIC)) { + # Newer V2 image header. + status = ERR + + # Initialize the output image header. + call strcpy (IMH_MAGICSTR, IM_MAGIC(im), SZ_IMMAGIC) + IM_HDRVER(im) = V2_VERSION + + # "sulen_userarea" is the length of the user area in SU. + if (miireadi (fd, hdrlen, 1) != 1) + goto readerr_ + sulen_userarea = hdrlen - LEN_V2IMHDR + IM_HDRLEN(im) = LEN_IMHDR + sulen_userarea + + if (miireadi (fd, IM_PIXTYPE(im), 1) != 1) + goto readerr_ + + # Determine whether to byte swap the pixels. + if (miireadi (fd, IM_SWAPPED(im), 1) != 1) + goto readerr_ + + IM_SWAP(im) = NO + switch (IM_PIXTYPE(im)) { + case TY_SHORT, TY_USHORT: + IM_SWAP(im) = btoi (IM_SWAPPED(im) != BYTE_SWAP2) + case TY_INT, TY_LONG: + IM_SWAP(im) = btoi (IM_SWAPPED(im) != BYTE_SWAP4) + case TY_REAL: + if (IEEE_USED == YES) + IM_SWAP(im) = btoi (IM_SWAPPED(im) != IEEE_SWAP4) + case TY_DOUBLE: + if (IEEE_USED == YES) + IM_SWAP(im) = btoi (IM_SWAPPED(im) != IEEE_SWAP8) + } + + # Read the fixed-format fields of the header. + if (miireadi (fd, IM_NDIM(im), 1) < 0) + goto readerr_ + if (miireadi (fd, IM_LEN(im,1), IM_MAXDIM) < 0) + goto readerr_ + if (miireadl (fd, IM_PHYSLEN(im,1), IM_MAXDIM) < 0) + goto readerr_ + if (miireadl (fd, IM_SSMTYPE(im), 1) < 0) + goto readerr_ + if (miireadl (fd, IM_LUTOFF(im), 1) < 0) + goto readerr_ + if (miireadl (fd, IM_PIXOFF(im), 1) < 0) + goto readerr_ + if (miireadl (fd, IM_HGMOFF(im), 1) < 0) + goto readerr_ + if (miireadl (fd, IM_BLIST(im), 1) < 0) + goto readerr_ + if (miireadl (fd, IM_SZBLIST(im), 1) < 0) + goto readerr_ + if (miireadl (fd, IM_NBPIX(im), 1) < 0) + goto readerr_ + if (miireadl (fd, IM_CTIME(im), 1) < 0) + goto readerr_ + if (miireadl (fd, IM_MTIME(im), 1) < 0) + goto readerr_ + if (miireadl (fd, IM_LIMTIME(im), 1) < 0) + goto readerr_ + + if (miireadr (fd, IM_MAX(im), 1) < 0) + goto readerr_ + if (miireadr (fd, IM_MIN(im), 1) < 0) + goto readerr_ + + if (miireadc (fd, IM_PIXFILE(im), SZ_V2IMPIXFILE) < 0) + goto readerr_ + if (miireadc (fd, IM_HDRFILE(im), SZ_V2IMHDRFILE) < 0) + goto readerr_ + if (miireadc (fd, IM_TITLE(im), SZ_V2IMTITLE) < 0) + goto readerr_ + if (miireadc (fd, IM_HISTORY(im), SZ_V2IMHIST) < 0) + goto readerr_ + + # Read the variable-length user area. + if (uchars > 0 && sulen_userarea > 0) { + nchars = min (uchars, sulen_userarea * SZ_MII_INT) + if (miireadc (fd, Memc[IM_USERAREA(im)], nchars) < 0) + goto readerr_ + } + + status = OK +readerr_ + return (status) + } + + return (ERR) +end diff --git a/sys/imio/iki/oif/oifrename.x b/sys/imio/iki/oif/oifrename.x new file mode 100644 index 00000000..edba1bcd --- /dev/null +++ b/sys/imio/iki/oif/oifrename.x @@ -0,0 +1,102 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include <imhdr.h> +include <imio.h> +include "oif.h" + +# OIF_RENAME -- Rename an image. A special operator is required since the image +# is stored as two files. + +procedure oif_rename (kernel, old_root, old_extn, new_root, new_extn, status) + +int kernel #I IKI kernel +char old_root[ARB] # old image root name +char old_extn[ARB] # old image extn +char new_root[ARB] # new image root name +char new_extn[ARB] # old image extn +int status + +pointer sp, im +bool heq, peq +pointer old_hfn, new_hfn +pointer old_pfn, new_pfn +int nchars, old_rootoff, new_rootoff, junk + +bool streq() +pointer immapz() +int access(), strlen(), strncmp() +errchk immapz, rename + +begin + call smark (sp) + call salloc (old_hfn, SZ_PATHNAME, TY_CHAR) + call salloc (new_hfn, SZ_PATHNAME, TY_CHAR) + call salloc (old_pfn, SZ_PATHNAME, TY_CHAR) + call salloc (new_pfn, SZ_PATHNAME, TY_CHAR) + + # Get filenames of old and new images. + call iki_mkfname (old_root, old_extn, Memc[old_hfn], SZ_PATHNAME) + call iki_mkfname (new_root, OIF_HDREXTN, Memc[new_hfn], SZ_PATHNAME) + heq = streq (Memc[old_hfn], Memc[new_hfn]) + + # Our task here is nontrivial as the pixel file must be renamed as + # well as the header file, e.g., since renaming the header file may + # move it to a different directory, and the PIXFILE field in the + # image header may indicate that the pixel file is in the same dir + # as the header. Must open image, get pixfile name from the header, + # and generate the new pixfile name. The CURRENT value of IMDIR is + # used to generate the new pixfile name. + + im = immapz (Memc[old_hfn], READ_WRITE, 0) + + if (IM_PIXFILE(im) != EOS) { + # Get old pixel file filename. + call oif_gpixfname (IM_PIXFILE(im), Memc[old_hfn], Memc[old_pfn], + SZ_PATHNAME) + + # Get new pixel file filename. + call strcpy (Memc[new_hfn], IM_HDRFILE(im), SZ_IMHDRFILE) + call oif_mkpixfname (im, Memc[new_pfn], SZ_PATHNAME) + + # Do not change the pixel file name if the name does not change + # other than by the addition of the "aa" style suffix added by + # mkpixfname. + + peq = false + call zfnbrk (old_root, old_rootoff, junk) + call zfnbrk (new_root, new_rootoff, junk) + peq = streq (old_root[old_rootoff], new_root[new_rootoff]) + + if (peq) { + nchars = strlen (Memc[new_pfn]) - strlen ("aa.imh") + peq = (strncmp (Memc[old_pfn], Memc[new_pfn], nchars) == 0) + } + + if (peq) + IM_UPDATE(im) = NO + else { + # If the pixel file rename fails do not rename the header file + # and do not change the name of the pixel file in the header. + + iferr (call rename (Memc[old_pfn], Memc[new_pfn])) { + if (access (Memc[old_pfn], 0, 0) == YES) { + IM_UPDATE(im) = NO + call imunmap (im) + call erract (EA_ERROR) + } + } + } + + } else + call strcpy (Memc[new_hfn], IM_HDRFILE(im), SZ_IMHDRFILE) + + call strcpy (Memc[old_hfn], IM_HDRFILE(im), SZ_IMHDRFILE) + call imunmap (im) + + # Rename the header file. + if (!heq) + call rename (Memc[old_hfn], Memc[new_hfn]) + + call sfree (sp) +end diff --git a/sys/imio/iki/oif/oifupdhdr.x b/sys/imio/iki/oif/oifupdhdr.x new file mode 100644 index 00000000..516d62c1 --- /dev/null +++ b/sys/imio/iki/oif/oifupdhdr.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <error.h> +include <imhdr.h> +include <imio.h> +include "oif.h" + +# OIF_UPDHDR -- Update the image header. + +procedure oif_updhdr (im, status) + +pointer im #I image descriptor +int status #O return status + +int hfd +errchk imerr, open, oif_wrhdr, flush +int open() + +begin + status = OK + hfd = IM_HFD(im) + + if (IM_ACMODE(im) == READ_ONLY) + call imerr (IM_NAME(im), SYS_IMUPIMHDR) + if (hfd == NULL) + hfd = open (IM_HDRFILE(im), READ_WRITE, BINARY_FILE) + + call oif_wrhdr (hfd, im, TY_IMHDR) + call flush (hfd) + + if (IM_HFD(im) == NULL) + call close (hfd) +end diff --git a/sys/imio/iki/oif/oifwrhdr.x b/sys/imio/iki/oif/oifwrhdr.x new file mode 100644 index 00000000..7b4e7349 --- /dev/null +++ b/sys/imio/iki/oif/oifwrhdr.x @@ -0,0 +1,233 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include <mach.h> +include <imio.h> +include "imhv1.h" +include "imhv2.h" +include "oif.h" + +# OIF_WRHDR -- Write an OIF image header. + +procedure oif_wrhdr (fd, im, htype) + +int fd #I header file descriptor +pointer im #I image descriptor +int htype #I TY_IMHDR or TY_PIXHDR + +pointer sp, v1, fname +int status, hdrlen, len_userarea +errchk write, miiwritec, miiwritei, miiwritel, miiwriter +int strlen() + +define v1done_ 91 +define v2start_ 92 +define v2done_ 93 + +begin + switch (IM_HDRVER(im)) { + case V1_VERSION: + # Old V1 image header. + # ---------------------- + + status = ERR + call smark (sp) + call salloc (v1, LEN_V1IMHDR, TY_STRUCT) + + # Initialize the output image header. + switch (htype) { + case TY_IMHDR: + call strcpy (V1_MAGIC, IM_V1MAGIC(v1), SZ_IMMAGIC) + hdrlen = LEN_V1IMHDR + case TY_PIXHDR: + call strcpy (V1_PMAGIC, IM_V1MAGIC(v1), SZ_IMMAGIC) + hdrlen = LEN_V1PIXHDR + default: + goto v1done_ + } + + # The following is the length of the user area in chars. + len_userarea = strlen (Memc[IM_USERAREA(im)]) + 1 + IM_V1HDRLEN(v1) = LEN_V1IMHDR + + (len_userarea + SZ_MII_INT-1) / SZ_MII_INT + + IM_V1PIXTYPE(v1) = IM_PIXTYPE(im) + IM_V1NDIM(v1) = IM_NDIM(im) + call amovl (IM_LEN(im,1), IM_V1LEN(v1,1), IM_MAXDIM) + call amovl (IM_PHYSLEN(im,1), IM_V1PHYSLEN(v1,1), IM_MAXDIM) + + IM_V1SSMTYPE(v1) = IM_SSMTYPE(im) + IM_V1LUTOFF(v1) = IM_LUTOFF(im) + IM_V1PIXOFF(v1) = IM_PIXOFF(im) + IM_V1HGMOFF(v1) = IM_HGMOFF(im) + IM_V1CTIME(v1) = IM_CTIME(im) + IM_V1MTIME(v1) = IM_MTIME(im) + IM_V1LIMTIME(v1) = IM_LIMTIME(im) + IM_V1MAX(v1) = IM_MAX(im) + IM_V1MIN(v1) = IM_MIN(im) + + if (strlen(IM_PIXFILE(im)) > SZ_V1IMPIXFILE) + goto v1done_ + if (strlen(IM_HDRFILE(im)) > SZ_V1IMHDRFILE) + goto v1done_ + + call strcpy (IM_PIXFILE(im), IM_V1PIXFILE(v1), SZ_V1IMPIXFILE) + call strcpy (IM_HDRFILE(im), IM_V1HDRFILE(v1), SZ_V1IMHDRFILE) + call strcpy (IM_TITLE(im), IM_V1TITLE(v1), SZ_V1IMTITLE) + call strcpy (IM_HISTORY(im), IM_V1HISTORY(v1), SZ_V1IMHIST) + + # For historical reasons the pixel file header stores the host + # pathname of the header file in the PIXFILE field of the pixel + # file header. + + if (htype == TY_PIXHDR) + call fpathname (IM_HDRFILE(im), IM_V1PIXFILE(v1), + SZ_V1IMPIXFILE) + + # Write the file header. + call seek (fd, BOFL) + call write (fd, IM_V1MAGIC(v1), hdrlen * SZ_MII_INT) + + # Write the user area. + if (htype == TY_IMHDR) + call write (fd, Memc[IM_USERAREA(im)], len_userarea) + + status = OK +v1done_ + call sfree (sp) + if (status != OK) + call syserrs (SYS_IKIUPDHDR, IM_NAME(im)) + + case V2_VERSION: + # Newer V2 image header. + # ---------------------- +v2start_ + status = ERR + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + + call seek (fd, BOFL) + + # Initialize the output image header. + switch (htype) { + case TY_IMHDR: + call miiwritec (fd, V2_MAGIC, SZ_IMMAGIC) + hdrlen = LEN_V2IMHDR + case TY_PIXHDR: + call miiwritec (fd, V2_PMAGIC, SZ_IMMAGIC) + hdrlen = LEN_V2PIXHDR + default: + goto v2done_ + } + + # The following is the length of the user area in SU. + len_userarea = strlen (Memc[IM_USERAREA(im)]) + 1 + hdrlen = LEN_V2IMHDR + (len_userarea + SZ_MII_INT-1) / SZ_MII_INT + + call miiwritei (fd, hdrlen, 1) + call miiwritei (fd, IM_PIXTYPE(im), 1) + + # Record the byte swapping used for this image. When writing a + # new image we use the native data type of the host and don't + # swap bytes, so IM_SWAPPED is YES if the host architecture is + # byte swapped. + + switch (IM_ACMODE(im)) { + case NEW_IMAGE, NEW_COPY, TEMP_FILE: + IM_SWAPPED(im) = -1 + switch (IM_PIXTYPE(im)) { + case TY_SHORT, TY_USHORT: + IM_SWAPPED(im) = BYTE_SWAP2 + case TY_INT, TY_LONG: + IM_SWAPPED(im) = BYTE_SWAP4 + case TY_REAL: + if (IEEE_USED == YES) + IM_SWAPPED(im) = IEEE_SWAP4 + case TY_DOUBLE: + if (IEEE_USED == YES) + IM_SWAPPED(im) = IEEE_SWAP8 + } + default: + # IM_SWAPPED should already be set in header. + } + + call miiwritei (fd, IM_SWAPPED(im), 1) + call miiwritei (fd, IM_NDIM(im), 1) + call miiwritel (fd, IM_LEN(im,1), IM_MAXDIM) + call miiwritel (fd, IM_PHYSLEN(im,1), IM_MAXDIM) + call miiwritel (fd, IM_SSMTYPE(im), 1) + call miiwritel (fd, IM_LUTOFF(im), 1) + call miiwritel (fd, IM_PIXOFF(im), 1) + call miiwritel (fd, IM_HGMOFF(im), 1) + call miiwritel (fd, IM_BLIST(im), 1) + call miiwritel (fd, IM_SZBLIST(im), 1) + call miiwritel (fd, IM_NBPIX(im), 1) + call miiwritel (fd, IM_CTIME(im), 1) + call miiwritel (fd, IM_MTIME(im), 1) + call miiwritel (fd, IM_LIMTIME(im), 1) + call miiwriter (fd, IM_MAX(im), 1) + call miiwriter (fd, IM_MIN(im), 1) + + if (strlen(IM_PIXFILE(im)) > SZ_V2IMPIXFILE) + goto v2done_ + if (strlen(IM_HDRFILE(im)) > SZ_V2IMHDRFILE) + goto v2done_ + + # For historical reasons the pixel file header stores the host + # pathname of the header file in the PIXFILE field of the pixel + # file header. + + if (htype == TY_PIXHDR) { + call aclrc (Memc[fname], SZ_PATHNAME) + call fpathname (IM_HDRFILE(im), Memc[fname], SZ_PATHNAME) + call miiwritec (fd, Memc[fname], SZ_V2IMPIXFILE) + status = OK + goto v2done_ + } else + call miiwritec (fd, IM_PIXFILE(im), SZ_V2IMPIXFILE) + + call oif_trim (IM_HDRFILE(im), SZ_V2IMHDRFILE) + call miiwritec (fd, IM_HDRFILE(im), SZ_V2IMHDRFILE) + + call oif_trim (IM_TITLE(im), SZ_V2IMTITLE) + call miiwritec (fd, IM_TITLE(im), SZ_V2IMTITLE) + + call oif_trim (IM_HISTORY(im), SZ_V2IMHIST) + call miiwritec (fd, IM_HISTORY(im), SZ_V2IMHIST) + + # Write the variable-length user area. + call miiwritec (fd, Memc[IM_USERAREA(im)], len_userarea) + + status = OK +v2done_ + call sfree (sp) + if (status != OK) + call syserrs (SYS_IKIUPDHDR, IM_NAME(im)) + + default: + IM_HDRVER(im) = V2_VERSION + goto v2start_ + } +end + + +# OIF_TRIM -- Trim trailing garbage at the end of a string. This does not +# affect the value of the string, but makes the contents of the output file +# clearer when examined with file utilities. + +procedure oif_trim (s, nchars) + +char s[ARB] +int nchars + +int n, ntrim +int strlen() + +begin + n = strlen(s) + 1 + ntrim = nchars - n + + if (ntrim > 0) + call aclrc (s[n], ntrim) +end diff --git a/sys/imio/iki/plf/README b/sys/imio/iki/plf/README new file mode 100644 index 00000000..0a2065c7 --- /dev/null +++ b/sys/imio/iki/plf/README @@ -0,0 +1,5 @@ +PLF -- Partial, IKI mini-driver for the pixel list (PLIO) image format. + +Only part of the IKI routines are implemented here. The open/close, header +access, and i/o functions are handled as a special case directly in the +IMIO code (see the impm*.x routines, and im[rd|wr]px.x). diff --git a/sys/imio/iki/plf/mkpkg b/sys/imio/iki/plf/mkpkg new file mode 100644 index 00000000..4253544e --- /dev/null +++ b/sys/imio/iki/plf/mkpkg @@ -0,0 +1,17 @@ +# Make the PLF image kernel (PLIO mask image kernel). + +$checkout libex.a lib$ +$update libex.a +$checkin libex.a lib$ +$exit + +libex.a: + plfaccess.x plf.h + plfclose.x <imhdr.h> <imio.h> <plset.h> + plfcopy.x plf.h <error.h> + plfdelete.x <error.h> + plfnull.x + plfopen.x <imhdr.h> <imio.h> <plio.h> <pmset.h> + plfrename.x plf.h <error.h> + plfupdhdr.x <imhdr.h> <imio.h> <plset.h> + ; diff --git a/sys/imio/iki/plf/plf.h b/sys/imio/iki/plf/plf.h new file mode 100644 index 00000000..7fc666a9 --- /dev/null +++ b/sys/imio/iki/plf/plf.h @@ -0,0 +1,4 @@ +# PLF.H -- IKI/PLF internal definitions. + +define PLF_EXTN "pl" # image header filename extension +define MAX_LENEXTN 3 # max length imagefile extension diff --git a/sys/imio/iki/plf/plfaccess.x b/sys/imio/iki/plf/plfaccess.x new file mode 100644 index 00000000..bf4ed5a9 --- /dev/null +++ b/sys/imio/iki/plf/plfaccess.x @@ -0,0 +1,44 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "plf.h" + +# PLF_ACCESS -- Test the accessibility or existence of an existing image, +# or the legality of the name of a new image. + +procedure plf_access (kernel, root, extn, acmode, status) + +int kernel #I IKI kernel +char root[ARB] #I root filename +char extn[ARB] #U extension (SET on output if none specified) +int acmode #I access mode (0 to test only existence) +int status #O ok or err + +pointer sp, fname +int btoi(), access(), iki_validextn() +string plf_extn PLF_EXTN + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + + # If new image, test only the legality of the given extension. + # This is used to select a kernel given the imagefile extension. + + status = NO + if (extn[1] != EOS) + status = btoi (iki_validextn (kernel, extn) > 0) + + if (acmode != NEW_IMAGE && acmode != NEW_COPY) { + if (extn[1] == EOS) { + call iki_mkfname (root, plf_extn, Memc[fname], SZ_PATHNAME) + status = access (Memc[fname], acmode, 0) + if (status != NO) + call strcpy (plf_extn, extn, MAX_LENEXTN) + } else if (status != NO) { + call iki_mkfname (root, extn, Memc[fname], SZ_PATHNAME) + status = access (Memc[fname], acmode, 0) + } + } + + call sfree (sp) +end diff --git a/sys/imio/iki/plf/plfclose.x b/sys/imio/iki/plf/plfclose.x new file mode 100644 index 00000000..2d2454e0 --- /dev/null +++ b/sys/imio/iki/plf/plfclose.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> +include <plset.h> + +# PLF_CLOSE -- Close a mask image. + +procedure plf_close (im, status) + +pointer im #I image descriptor +int status #O output status + +begin + if (IM_PFD(im) != NULL) + call close (IM_PFD(im)) + if (and (IM_PLFLAGS(im), PL_CLOSEPL) != 0) + call pl_close (IM_PL(im)) + + IM_PL(im) = NULL +end diff --git a/sys/imio/iki/plf/plfcopy.x b/sys/imio/iki/plf/plfcopy.x new file mode 100644 index 00000000..4cfb2b6e --- /dev/null +++ b/sys/imio/iki/plf/plfcopy.x @@ -0,0 +1,38 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include "plf.h" + +# PLF_COPY -- Copy an image. A special operator is provided for fast, blind +# copies of entire images. + +procedure plf_copy (kernel, old_root, old_extn, new_root, new_extn, status) + +int kernel #I IKI kernel +char old_root[ARB] #I old image root name +char old_extn[ARB] #I old image extn +char new_root[ARB] #I new image root name +char new_extn[ARB] #I new extn +int status #O output status + +pointer sp +pointer oldname, newname + +begin + call smark (sp) + call salloc (oldname, SZ_PATHNAME, TY_CHAR) + call salloc (newname, SZ_PATHNAME, TY_CHAR) + + # Get filename of old and new images. + call iki_mkfname (old_root, old_extn, Memc[oldname], SZ_PATHNAME) + call iki_mkfname (new_root, PLF_EXTN, Memc[newname], SZ_PATHNAME) + + # Copy the PLIO mask save file. + iferr (call fcopy (Memc[oldname], Memc[newname])) { + call erract (EA_WARN) + status = ERR + } else + status = OK + + call sfree (sp) +end diff --git a/sys/imio/iki/plf/plfdelete.x b/sys/imio/iki/plf/plfdelete.x new file mode 100644 index 00000000..4fad68aa --- /dev/null +++ b/sys/imio/iki/plf/plfdelete.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> + +# PLF_DELETE -- Delete a PLIO mask savefile (mask image). + +procedure plf_delete (kernel, root, extn, status) + +int kernel #I IKI kernel +char root[ARB] #I root filename +char extn[ARB] #I extension +int status #O output status + +pointer sp, fname +errchk delete + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + + call iki_mkfname (root, extn, Memc[fname], SZ_PATHNAME) + iferr (call delete (Memc[fname])) { + call erract (EA_WARN) + status = ERR + } else + status = OK + + call sfree (sp) +end diff --git a/sys/imio/iki/plf/plfnull.x b/sys/imio/iki/plf/plfnull.x new file mode 100644 index 00000000..83ec77cd --- /dev/null +++ b/sys/imio/iki/plf/plfnull.x @@ -0,0 +1,9 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# PLF_NULL -- Null driver entry point. + +procedure plf_null() + +begin + call error (1, "PLF image kernel abort - null driver entry point") +end diff --git a/sys/imio/iki/plf/plfopen.x b/sys/imio/iki/plf/plfopen.x new file mode 100644 index 00000000..ec65d647 --- /dev/null +++ b/sys/imio/iki/plf/plfopen.x @@ -0,0 +1,90 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include <imio.h> +include <pmset.h> +include <plio.h> + + +# PLF_OPEN -- Open a PMIO mask on an image descriptor. + +procedure plf_open (kernel, im, o_im, + root, extn, ksection, cl_index, cl_size, acmode, status) + +int kernel #I IKI kernel +pointer im #I image descriptor +pointer o_im #I [not used] +char root[ARB] #I root image name +char extn[ARB] #I filename extension +char ksection[ARB] #I QPIO filter expression +int cl_index #I [not used] +int cl_size #I [not used] +int acmode #I [not used] +int status #O ok|err + +pointer sp, fname, hp, pl +int naxes, axlen[IM_MAXDIM], depth +bool envgetb(), fnullfile() +pointer pl_open() +int access() +errchk imerr + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + call salloc (hp, IM_LENHDRMEM(im), TY_CHAR) + + # The only valid cl_index for a PL image is -1 (none specified) or 1. + if (!(cl_index < 0 || cl_index == 1)) { + call sfree (sp) + status = ERR + return + } + + # Get mask file name. + call iki_mkfname (root, extn, Memc[fname], SZ_PATHNAME) + call aclrc (IM_HDRFILE(im), SZ_IMHDRFILE) + call strcpy (Memc[fname], IM_HDRFILE(im), SZ_IMHDRFILE) + + # Open an empty mask. + pl = pl_open (NULL) + + if (acmode == NEW_IMAGE || acmode == NEW_COPY) { + # Check that we will not be clobbering an existing mask. + if (!fnullfile(Memc[fname]) && access (Memc[fname], 0, 0) == YES) + if (envgetb ("imclobber")) { + iferr (call delete (Memc[fname])) + ; + } else { + call pl_close (pl) + call imerr (IM_NAME(im), SYS_IKICLOB) + } + } else { + # Load the named mask if opening an existing mask image. + iferr (call pl_loadf (pl,Memc[fname],Memc[hp],IM_LENHDRMEM(im))) { + call pl_close (pl) + call sfree (sp) + status = ERR + return + } + + # Set the image size. + call pl_gsize (pl, naxes, axlen, depth) + + IM_NDIM(im) = naxes + call amovl (axlen, IM_LEN(im,1), IM_MAXDIM) + call imioff (im, 1, YES, 1) + + # Restore the header cards. + call im_pmldhdr (im, hp) + } + + # More set up of the image descriptor. + IM_PL(im) = pl + IM_PLFLAGS(im) = PL_CLOSEPL + IM_PIXTYPE(im) = TY_INT + + status = OK + call sfree (sp) +end diff --git a/sys/imio/iki/plf/plfrename.x b/sys/imio/iki/plf/plfrename.x new file mode 100644 index 00000000..1ab47507 --- /dev/null +++ b/sys/imio/iki/plf/plfrename.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include "plf.h" + +# PLF_RENAME -- Rename a PLIO mask savefile (mask image). + +procedure plf_rename (kernel, old_root, old_extn, new_root, new_extn, status) + +int kernel #I IKI kernel +char old_root[ARB] #I old image root name +char old_extn[ARB] #I old image extn +char new_root[ARB] #I new image root name +char new_extn[ARB] #I old image extn +int status #O output status + +pointer sp, oldname, newname +errchk rename + +begin + call smark (sp) + call salloc (oldname, SZ_PATHNAME, TY_CHAR) + call salloc (newname, SZ_PATHNAME, TY_CHAR) + + # Get filenames of old and new datafiles. + call iki_mkfname (old_root, old_extn, Memc[oldname], SZ_PATHNAME) + call iki_mkfname (new_root, PLF_EXTN, Memc[newname], SZ_PATHNAME) + + # Rename the datafile. + iferr (call rename (Memc[oldname], Memc[newname])) { + call erract (EA_WARN) + status = ERR + } else + status = OK + + call sfree (sp) +end diff --git a/sys/imio/iki/plf/plfupdhdr.x b/sys/imio/iki/plf/plfupdhdr.x new file mode 100644 index 00000000..e8cb8784 --- /dev/null +++ b/sys/imio/iki/plf/plfupdhdr.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> +include <plset.h> + +# PLF_UPDHDR -- Update the image header. + +procedure plf_updhdr (im, status) + +pointer im #I image descriptor +int status #O output status + +pointer bp +int nchars, flags, sz_buf +int im_pmsvhdr() + +begin + status = OK + + flags = 0 + if (IM_ACMODE(im) == READ_WRITE) + flags = PL_UPDATE + + bp = NULL + iferr { + nchars = im_pmsvhdr (im, bp, sz_buf) + call pl_savef (IM_PL(im), IM_HDRFILE(im), Memc[bp], flags) + } then + status = ERR + + call mfree (bp, TY_CHAR) +end diff --git a/sys/imio/iki/qpf/README b/sys/imio/iki/qpf/README new file mode 100644 index 00000000..cea44538 --- /dev/null +++ b/sys/imio/iki/qpf/README @@ -0,0 +1,2 @@ +IKI/QPF -- IKI kernel for the QPOE (position ordered event file) image format. +See the QPOE source directories for additional information on QPOE. diff --git a/sys/imio/iki/qpf/mkpkg b/sys/imio/iki/qpf/mkpkg new file mode 100644 index 00000000..eb3e8efd --- /dev/null +++ b/sys/imio/iki/qpf/mkpkg @@ -0,0 +1,22 @@ +# Make the IKI/QPF interface (photon image kernel). + +$checkout libex.a lib$ +$update libex.a +$checkin libex.a lib$ +$exit + +libex.a: + qpfaccess.x qpf.h + qpfclose.x qpf.h <imhdr.h> <imio.h> + qpfcopy.x qpf.h <error.h> + qpfcopypar.x qpf.h <error.h> <imhdr.h> <imio.h> <qpset.h> + qpfdelete.x <error.h> + qpfopen.x qpf.h <error.h> <imhdr.h> <imio.h> <mach.h>\ + <qpioset.h> <qpset.h> + qpfopix.x qpf.h <imhdr.h> <imio.h> + qpfrename.x qpf.h <error.h> + qpfupdhdr.x + qpfwattr.x qpf.h <ctype.h> <qpioset.h> + qpfwfilter.x qpf.h + zfioqp.x qpf.h <fio.h> <imhdr.h> <imio.h> <mach.h> <qpioset.h> + ; diff --git a/sys/imio/iki/qpf/qpf.h b/sys/imio/iki/qpf/qpf.h new file mode 100644 index 00000000..37e29cee --- /dev/null +++ b/sys/imio/iki/qpf/qpf.h @@ -0,0 +1,20 @@ +# QPF.H -- IKI/QPF internal definitions. + +define QPF_EXTN "qp" # image header filename extension +define MAX_LENEXTN 3 # max length imagefile extension +define SZ_KWNAME 8 # size of a FITS keyword name +define SZ_BIGSTR 64 # max length string per FITS card +define SZ_MAXFILTER 4096 # max size QPIO filter (for log only) + +define LEN_QPFDES 10 +define QPF_IM Memi[$1] # backpointer to image descriptor +define QPF_QP Memi[$1+1] # QPOE datafile descriptor +define QPF_IO Memi[$1+2] # QPIO descriptor +define QPF_XBLOCK Memr[P2R($1+3)] # X block factor for sampling +define QPF_YBLOCK Memr[P2R($1+4)] # Y block factor for sampling +define QPF_VS Memi[$1+5+$2-1] # start vector of active rect +define QPF_VE Memi[$1+7+$2-1] # end vector of active rect +define QPF_IOSTAT Memi[$1+9] # i/o status (byte count) + +# QPOE parameters to be omitted from the IMIO header user parameter list. +define OMIT "|naxes|axlen|datamin|datamax|cretime|modtime|limtime|" diff --git a/sys/imio/iki/qpf/qpfaccess.x b/sys/imio/iki/qpf/qpfaccess.x new file mode 100644 index 00000000..52d0b06f --- /dev/null +++ b/sys/imio/iki/qpf/qpfaccess.x @@ -0,0 +1,44 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "qpf.h" + +# QPF_ACCESS -- Test the accessibility or existence of an existing image, +# or the legality of the name of a new image. + +procedure qpf_access (kernel, root, extn, acmode, status) + +int kernel #I IKI kernel +char root[ARB] #I root filename +char extn[ARB] #U extension (SET on output if none specified) +int acmode #I access mode (0 to test only existence) +int status #O ok or err + +pointer sp, fname +int btoi(), qp_access(), iki_validextn() +string qpf_extn QPF_EXTN + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + + # If new image, test only the legality of the given extension. + # This is used to select a kernel given the imagefile extension. + + status = NO + if (extn[1] != EOS) + status = btoi (iki_validextn (kernel, extn) > 0) + + if (acmode != NEW_IMAGE && acmode != NEW_COPY) { + if (extn[1] == EOS) { + call iki_mkfname (root, qpf_extn, Memc[fname], SZ_PATHNAME) + status = qp_access (Memc[fname], acmode) + if (status != NO) + call strcpy (qpf_extn, extn, MAX_LENEXTN) + } else if (status != NO) { + call iki_mkfname (root, extn, Memc[fname], SZ_PATHNAME) + status = qp_access (Memc[fname], acmode) + } + } + + call sfree (sp) +end diff --git a/sys/imio/iki/qpf/qpfclose.x b/sys/imio/iki/qpf/qpfclose.x new file mode 100644 index 00000000..b4bad7b4 --- /dev/null +++ b/sys/imio/iki/qpf/qpfclose.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> +include "qpf.h" + +# QPF_CLOSE -- Close a QPOE image. + +procedure qpf_close (im, status) + +pointer im #I image descriptor +int status #O output status + +pointer qpf + +begin + # Close the QPF virtual file driver. + if (IM_PFD(im) != NULL) + call close (IM_PFD(im)) + + # Close the various descriptors. + qpf = IM_KDES(im) + if (QPF_IO(qpf) != NULL) + call qpio_close (QPF_IO(qpf)) + if (QPF_QP(qpf) != NULL) + call qp_close (QPF_QP(qpf)) + + call mfree (qpf, TY_STRUCT) +end diff --git a/sys/imio/iki/qpf/qpfcopy.x b/sys/imio/iki/qpf/qpfcopy.x new file mode 100644 index 00000000..ebc2fa5b --- /dev/null +++ b/sys/imio/iki/qpf/qpfcopy.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include "qpf.h" + +# QPF_COPY -- Copy an image. A special operator is provided for fast, blind +# copies of entire images. + +procedure qpf_copy (kernel, old_root, old_extn, new_root, new_extn, status) + +int kernel #I IKI kernel +char old_root[ARB] #I old image root name +char old_extn[ARB] #I old image extn +char new_root[ARB] #I new image root name +char new_extn[ARB] #I new extn +int status #O output status + +pointer sp +pointer oldname, newname +errchk qp_copy + +begin + call smark (sp) + call salloc (oldname, SZ_PATHNAME, TY_CHAR) + call salloc (newname, SZ_PATHNAME, TY_CHAR) + + # Get filename of old and new images. + call iki_mkfname (old_root, old_extn, Memc[oldname], SZ_PATHNAME) + call iki_mkfname (new_root, QPF_EXTN, Memc[newname], SZ_PATHNAME) + + # Copy the datafile. + iferr (call qp_copy (Memc[oldname], Memc[newname])) { + call erract (EA_WARN) + status = ERR + } else + status = OK + + call sfree (sp) +end diff --git a/sys/imio/iki/qpf/qpfcopypar.x b/sys/imio/iki/qpf/qpfcopypar.x new file mode 100644 index 00000000..cfa94c62 --- /dev/null +++ b/sys/imio/iki/qpf/qpfcopypar.x @@ -0,0 +1,117 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include <imhdr.h> +include <imio.h> +include <qpset.h> +include "qpf.h" + +# QPF_COPYPARAMS -- Copy parameters from the QPOE datafile header into the +# image header. Only scalar parameters are copied. + +procedure qpf_copyparams (im, qp) + +pointer im #I image descriptor +pointer qp #I QPOE descriptor + +int nelem, dtype, maxelem, flags +pointer sp, param, text, comment, datatype, fl, qpf, mw, io + +pointer qp_ofnlu(), qpio_loadwcs() +int qp_gnfn(), qp_queryf(), stridx(), strdic() +errchk qp_ofnlu, qp_gnfn, qp_queryf, imaddi, qp_geti, mw_saveim + +bool qp_getb() +short qp_gets() +int qp_geti(), qp_gstr() +real qp_getr() +double qp_getd() + +begin + call smark (sp) + call salloc (text, SZ_LINE, TY_CHAR) + call salloc (param, SZ_FNAME, TY_CHAR) + call salloc (comment, SZ_COMMENT, TY_CHAR) + call salloc (datatype, SZ_DATATYPE, TY_CHAR) + + qpf = IM_KDES(im) + + # Copy QPOE special keywords. + call imaddi (im, "NAXES", qp_geti(qp,"naxes")) + call imaddi (im, "AXLEN1", qp_geti(qp,"axlen[1]")) + call imaddi (im, "AXLEN2", qp_geti(qp,"axlen[2]")) + call imaddr (im, "XBLOCK", QPF_XBLOCK(qpf)) + call imaddr (im, "YBLOCK", QPF_YBLOCK(qpf)) + + # Output the QPOE filter. + iferr (call qpf_wfilter (qpf, im)) + call erract (EA_WARN) + + # Compute and output any filter attributes. + iferr (call qpf_wattr (qpf, im)) + call erract (EA_WARN) + + # Copy the WCS, if any. + io = QPF_IO(qpf) + if (io != NULL) + ifnoerr (mw = qpio_loadwcs (io)) { + call mw_saveim (mw, im) + call mw_close (mw) + } + + # Copy general keywords. + fl = qp_ofnlu (qp, "*") + + while (qp_gnfn (fl, Memc[param], SZ_FNAME) != EOF) { + # Get the next scalar parameter which has a nonnull value. + nelem = qp_queryf (qp, Memc[param], Memc[datatype], maxelem, + Memc[comment], flags) + if (strdic (Memc[param], Memc[text], SZ_LINE, OMIT) > 0) + next + + dtype = stridx (Memc[datatype], "bcsilrdx") + + # Make entry for a parameter which has no value, or an unprintable + # value. + + if (nelem == 0 || (nelem > 1 && dtype != TY_CHAR) || + dtype < TY_BOOL || dtype > TY_COMPLEX) { + + call sprintf (Memc[text], SZ_LINE, "%14s[%03d] %s") + call pargstr (Memc[datatype]) + call pargi (nelem) + call pargstr (Memc[comment]) + + iferr (call imastr (im, Memc[param], Memc[text])) + call erract (EA_WARN) + next + } + + # Copy parameter to image header. + iferr { + switch (dtype) { + case TY_BOOL: + call imaddb (im, Memc[param], qp_getb(qp,Memc[param])) + case TY_CHAR: + if (qp_gstr (qp, Memc[param], Memc[text], SZ_LINE) > 0) + call imastr (im, Memc[param], Memc[text]) + case TY_SHORT: + call imadds (im, Memc[param], qp_gets(qp,Memc[param])) + case TY_INT, TY_LONG: + call imaddi (im, Memc[param], qp_geti(qp,Memc[param])) + case TY_REAL: + call imaddr (im, Memc[param], qp_getr(qp,Memc[param])) + case TY_DOUBLE: + call imaddd (im, Memc[param], qp_getd(qp,Memc[param])) + case TY_COMPLEX: + ; # not supported. + } + } then { + call erract (EA_WARN) + break + } + } + + call qp_cfnl (fl) + call sfree (sp) +end diff --git a/sys/imio/iki/qpf/qpfdelete.x b/sys/imio/iki/qpf/qpfdelete.x new file mode 100644 index 00000000..c503c174 --- /dev/null +++ b/sys/imio/iki/qpf/qpfdelete.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> + +# QPF_DELETE -- Delete a datafile. + +procedure qpf_delete (kernel, root, extn, status) + +int kernel #I IKI kernel +char root[ARB] #I root filename +char extn[ARB] #I extension +int status #O output status + +pointer sp, fname +errchk qp_delete + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + + call iki_mkfname (root, extn, Memc[fname], SZ_PATHNAME) + iferr (call qp_delete (Memc[fname])) { + call erract (EA_WARN) + status = ERR + } else + status = OK + + call sfree (sp) +end diff --git a/sys/imio/iki/qpf/qpfopen.x b/sys/imio/iki/qpf/qpfopen.x new file mode 100644 index 00000000..99a57df1 --- /dev/null +++ b/sys/imio/iki/qpf/qpfopen.x @@ -0,0 +1,165 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include <mach.h> +include <imhdr.h> +include <imio.h> +include <qpset.h> +include <qpioset.h> +include "qpf.h" + +# QPF_OPEN -- Open a QPOE image. New QPOE images can only be written by +# calling QPOE directly; under IMIO, only READ_ONLY access is supported. + +procedure qpf_open (kernel, im, o_im, + root, extn, ksection, cl_index, cl_size, acmode, status) + +int kernel #I IKI kernel +pointer im #I image descriptor +pointer o_im #I [not used] +char root[ARB] #I root image name +char extn[ARB] #I filename extension +char ksection[ARB] #I QPIO filter expression +int cl_index #I [not used] +int cl_size #I [not used] +int acmode #I [not used] +int status #O ok|err + +int n +real xblock, yblock, tol +pointer sp, qp, io, v, fname, qpf + +pointer qp_open, qpio_open() +real qpio_statr(), qp_statr() +int qpio_getrange(), qp_geti(), qp_gstr(), qp_lenf() +define err_ 91 + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + call salloc (v, SZ_FNAME, TY_CHAR) + + io = NULL + qp = NULL + qpf = NULL + tol = EPSILONR * 100 + + # The only valid cl_index for a QPOE image is -1 (none specified) or 1. + if (!(cl_index < 0 || cl_index == 1)) + goto err_ + + call malloc (qpf, LEN_QPFDES, TY_STRUCT) + + # Open the QPOE file. + call iki_mkfname (root, extn, Memc[fname], SZ_PATHNAME) + iferr (qp = qp_open (Memc[fname], READ_ONLY, 0)) { + qp = NULL + goto err_ + } + + # Open the event list under QPIO for sampled (pixel) i/o. + iferr (io = qpio_open (qp, ksection, READ_ONLY)) + io = NULL + + # Determine the data range and pixel type. + iferr (IM_CTIME(im) = qp_geti (qp, "cretime")) + IM_CTIME(im) = 0 + iferr (IM_MTIME(im) = qp_geti (qp, "modtime")) + IM_MTIME(im) = 0 + iferr (IM_LIMTIME(im) = qp_geti (qp, "limtime")) + IM_LIMTIME(im) = 0 + + # The min and max pixel values for a sampled event file depend + # strongly on the blocking factor, which is a runtime variable. + # Ideally when the poefile is written the vectors 'datamin' and + # 'datamax' should be computed for the main event list. These + # give the min and max pixel values (counts/pixel) for each blocking + # factor from 1 to len(data[min|max]), i.e., the blocking factor + # serves as the index into these vectors. + + if (io != NULL) { + xblock = max (1.0, qpio_statr (io, QPIO_XBLOCKFACTOR)) + yblock = max (1.0, qpio_statr (io, QPIO_YBLOCKFACTOR)) + } else { + xblock = max (1.0, qp_statr (qp, QPOE_XBLOCKFACTOR)) + yblock = max (1.0, qp_statr (qp, QPOE_YBLOCKFACTOR)) + } + call strcpy ("datamax", Memc[v], SZ_FNAME) + n = qp_lenf (qp, Memc[v]) + + if (n >= max(xblock,yblock)) { + call sprintf (Memc[v+7], SZ_FNAME-7, "[%d]") + call pargi (nint((xblock+yblock)/2)) + IM_MAX(im) = qp_geti (qp, Memc[v]) + Memc[v+5] = 'i'; Memc[v+6] = 'n' + IM_MIN(im) = qp_geti (qp, Memc[v]) + } else + IM_LIMTIME(im) = 0 + + # Set the image pixel type. This is arbitrary, provided we have + # enough dynamic range to represent the maximum pixel value. + + IM_PIXTYPE(im) = TY_INT + if (IM_LIMTIME(im) != 0 && IM_LIMTIME(im) >= IM_MTIME(im)) + if (int(IM_MAX(im)) <= MAX_SHORT) + IM_PIXTYPE(im) = TY_SHORT + + # Set the image size parameters. If the user has specified a rect + # within which i/o is to occur, set the logical image size to the + # size of the rect rather than the full matrix. + + if (io != NULL) { + IM_NDIM(im) = qpio_getrange (io, QPF_VS(qpf,1), QPF_VE(qpf,1), 2) + IM_LEN(im,1) = (QPF_VE(qpf,1) - QPF_VS(qpf,1) + 1) / xblock + tol + IM_LEN(im,2) = (QPF_VE(qpf,2) - QPF_VS(qpf,2) + 1) / yblock + tol + } else { + IM_NDIM(im) = 2 + IM_LEN(im,1) = qp_geti (qp, "axlen[1]") / xblock + tol + IM_LEN(im,2) = qp_geti (qp, "axlen[2]") / yblock + tol + QPF_VS(qpf,1) = 1; QPF_VE(qpf,1) = IM_LEN(im,1) + QPF_VS(qpf,2) = 1; QPF_VE(qpf,2) = IM_LEN(im,2) + } + call imioff (im, 1, YES, 1) + + iferr (n = qp_gstr (qp, "title", IM_TITLE(im), SZ_IMTITLE)) + IM_TITLE(im) = EOS + iferr (n = qp_gstr (qp, "history", IM_HISTORY(im), SZ_IMHIST)) + IM_HISTORY(im) = EOS + + call strcpy (root, IM_HDRFILE(im), SZ_IMHDRFILE) + IM_PIXFILE(im) = EOS + IM_HFD(im) = NULL + IM_PFD(im) = NULL + + # Set up the QPF descriptor. + QPF_IM(qpf) = im + QPF_QP(qpf) = qp + QPF_IO(qpf) = io + QPF_XBLOCK(qpf) = xblock + QPF_YBLOCK(qpf) = yblock + QPF_IOSTAT(qpf) = 0 + + IM_KDES(im) = qpf + + # Copy any scalar QPOE file header parameters into the IMIO header. + iferr (call qpf_copyparams (im, qp)) + call erract (EA_WARN) + + status = OK + call sfree (sp) + return + +err_ + # Error abort. + if (io != NULL) + call qpio_close (io) + if (qp != NULL) + call qp_close (qp) + + call mfree (qpf, TY_STRUCT) + IM_KDES(im) = NULL + + status = ERR + call erract (EA_WARN) + call sfree (sp) +end diff --git a/sys/imio/iki/qpf/qpfopix.x b/sys/imio/iki/qpf/qpfopix.x new file mode 100644 index 00000000..9b5750ff --- /dev/null +++ b/sys/imio/iki/qpf/qpfopix.x @@ -0,0 +1,55 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> +include "qpf.h" + +# QPF_OPIX -- Open the "pixel storage file", i.e., open the special QPF/QPOE +# virtual file driver, which samples the QPOE event list in real time to +# produce image "pixels", where each pixel contains a count of the number of +# photons mapping to that point in the output image matrix. + +procedure qpf_opix (im, status) + +pointer im #I image descriptor +int status #O return status + +pointer sp, fname, qpf +extern qpfzop(), qpfzrd(), qpfzwr(), qpfzwt(), qpfzst(), qpfzcl() +int fopnbf() + +begin + status = OK + if (IM_PFD(im) != NULL) + return + + # Verify that the QPIO open succeeded at open time; if not, the file + # may not have an event list (which is legal, but not for pixel i/o). + + qpf = IM_KDES(im) + if (QPF_IO(qpf) == NULL) { + status = ERR + return + } + + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + + # Encode the QPF descriptor as a pseudo-filename to pass the descriptor + # through fopnbf to the QPF virtual binary file driver. + + call sprintf (Memc[fname], SZ_FNAME, "QPF%d") + call pargi (IM_KDES(im)) + + # Open a file descriptor for the dummy QPOE file driver, used to access + # the event list as a virtual pixel array (sampled at runtime). + + iferr (IM_PFD(im) = fopnbf (Memc[fname], READ_ONLY, + qpfzop, qpfzrd, qpfzwr, qpfzwt, qpfzst, qpfzcl)) { + + IM_PFD(im) = NULL + status = ERR + } + + call sfree (sp) +end diff --git a/sys/imio/iki/qpf/qpfrename.x b/sys/imio/iki/qpf/qpfrename.x new file mode 100644 index 00000000..70f90626 --- /dev/null +++ b/sys/imio/iki/qpf/qpfrename.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include "qpf.h" + +# QPF_RENAME -- Rename a datafile. + +procedure qpf_rename (kernel, old_root, old_extn, new_root, new_extn, status) + +int kernel #I IKI kernel +char old_root[ARB] #I old image root name +char old_extn[ARB] #I old image extn +char new_root[ARB] #I new image root name +char new_extn[ARB] #I old image extn +int status #O output status + +pointer sp, oldname, newname +errchk qp_rename + +begin + call smark (sp) + call salloc (oldname, SZ_PATHNAME, TY_CHAR) + call salloc (newname, SZ_PATHNAME, TY_CHAR) + + # Get filenames of old and new datafiles. + call iki_mkfname (old_root, old_extn, Memc[oldname], SZ_PATHNAME) + call iki_mkfname (new_root, QPF_EXTN, Memc[newname], SZ_PATHNAME) + + # Rename the datafile. + iferr (call qp_rename (Memc[oldname], Memc[newname])) { + call erract (EA_WARN) + status = ERR + } else + status = OK + + call sfree (sp) +end diff --git a/sys/imio/iki/qpf/qpfupdhdr.x b/sys/imio/iki/qpf/qpfupdhdr.x new file mode 100644 index 00000000..9dd67ea6 --- /dev/null +++ b/sys/imio/iki/qpf/qpfupdhdr.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# QPF_UPDHDR -- Update the image header. This is a no-op for QPF since the +# datafiles can only be accessed READ_ONLY via IMIO. + +procedure qpf_updhdr (im, status) + +pointer im #I image descriptor +int status #O output status + +begin + status = OK +end diff --git a/sys/imio/iki/qpf/qpfwattr.x b/sys/imio/iki/qpf/qpfwattr.x new file mode 100644 index 00000000..b48a6793 --- /dev/null +++ b/sys/imio/iki/qpf/qpfwattr.x @@ -0,0 +1,191 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <ctype.h> +include <qpioset.h> +include "qpf.h" + +# QPF_WATTR -- Record information about the attributes of the filter +# expression used to generate an image. Currently the only value which can be +# computed and recorded is total range (integral of the in-range intervals) of +# the range list defining an attribute, for example, the total exposure time +# defined by the time range list used to filter the data. +# +# This routine is driven by a set of optional QPOE header keywords of the +# form +# +# Keyword String Value +# +# defattrN <param-name> = "integral" <attribute-name>[:type] +# e.g. +# defattr1 "exptime = integral time:d" +# +# where param-name is the parameter name to be written to the output image +# header, "integral" is the value to be computed, and attribute-name is the +# QPEX attribute (e.g., "time") to be used for the computation. A finite +# value is returned for the integral if a range list is given for the named +# attribute and the range is closed. If the range is open on either or both +# ends, or no range expression is defined for the attribute, then INDEF is +# returned for the value of the integral. + +procedure qpf_wattr (qpf, im) + +pointer qpf #I QPF descriptor +pointer im #I image descriptor + +real r1, r2, rsum +double d1, d2, dsum +int dtype, i, j, xlen, nranges, i1, i2, isum +pointer sp, io, qp, ex, kwname, kwval, pname, funame, atname, ip, xs, xe + +bool strne() +pointer qpio_stati() +int qp_gstr(), ctowrd(), qp_accessf() +int qpex_attrli(), qpex_attrlr(), qpex_attrld() +errchk qpex_attrli, qpex_attrlr, qpex_attrld, imaddi, imaddr, imaddd + +begin + io = QPF_IO(qpf) + if (io == NULL) + return + + qp = QPF_QP(qpf) + ex = qpio_stati (io, QPIO_EX) + + call smark (sp) + call salloc (kwname, SZ_FNAME, TY_CHAR) + call salloc (kwval, SZ_LINE, TY_CHAR) + call salloc (pname, SZ_FNAME, TY_CHAR) + call salloc (funame, SZ_FNAME, TY_CHAR) + call salloc (atname, SZ_FNAME, TY_CHAR) + + # Process a sequence of "defattrN" header parameter definitions. + # Each defines a parameter to be computed and added to the output + # image header. + + do i = 1, ARB { + # Check for a parameter named "defattrN", get string value. + call sprintf (Memc[kwname], SZ_FNAME, "defattr%d") + call pargi (i) + + if (qp_accessf (qp, Memc[kwname]) == NO) + break + if (qp_gstr (qp, Memc[kwname], Memc[kwval], SZ_LINE) <= 0) + break + + # Parse string value into parameter name, function name, + # expression attribute name, and datatype. + + ip = kwval + if (ctowrd (Memc, ip, Memc[pname], SZ_FNAME) <= 0) + break + while (IS_WHITE(Memc[ip]) || Memc[ip] == '=') + ip = ip + 1 + if (ctowrd (Memc, ip, Memc[funame], SZ_FNAME) <= 0) + break + if (ctowrd (Memc, ip, Memc[atname], SZ_FNAME) <= 0) + break + + dtype = TY_INT + for (ip=atname; Memc[ip] != EOS; ip=ip+1) + if (Memc[ip] == ':') { + Memc[ip] = EOS + if (Memc[ip+1] == 'd') + dtype = TY_DOUBLE + else if (Memc[ip+1] == 'r') + dtype = TY_REAL + else + call eprintf ("QPF.defattr: datatype not recognized\n") + } + + # Verify known function type. + if (strne (Memc[funame], "integral")) { + call eprintf ("QPF.defattr: function `%s' not recognized\n") + call pargstr (Memc[funame]) + break + } + + # Compute the integral of the range list for the named attribute. + xlen = 0 + xs = NULL + xe = NULL + + switch (dtype) { + case TY_REAL: + if (ex == NULL) + nranges = 0 + else + nranges = qpex_attrlr (ex, Memc[atname], xs, xe, xlen) + + if (nranges <= 0) + rsum = INDEFR + else { + rsum = 0 + do j = 1, nranges { + r1 = Memr[xs+j-1] + r2 = Memr[xe+j-1] + if (IS_INDEFR(r1) || IS_INDEFR(r2)) { + rsum = INDEFR + break + } else + rsum = rsum + (r2 - r1) + } + } + + call mfree (xs, TY_REAL) + call mfree (xe, TY_REAL) + call imaddr (im, Memc[pname], rsum) + + case TY_DOUBLE: + if (ex == NULL) + nranges = 0 + else + nranges = qpex_attrld (ex, Memc[atname], xs, xe, xlen) + + if (nranges <= 0) + dsum = INDEFD + else { + dsum = 0 + do j = 1, nranges { + d1 = Memd[xs+j-1] + d2 = Memd[xe+j-1] + if (IS_INDEFD(d1) || IS_INDEFD(d2)) { + dsum = INDEFD + break + } else + dsum = dsum + (d2 - d1) + } + } + + call mfree (xs, TY_DOUBLE) + call mfree (xe, TY_DOUBLE) + call imaddd (im, Memc[pname], dsum) + + default: + if (ex == NULL) + nranges = 0 + else + nranges = qpex_attrli (ex, Memc[atname], xs, xe, xlen) + + if (nranges <= 0) + isum = INDEFI + else { + isum = 0 + do j = 1, nranges { + i1 = Memi[xs+j-1] + i2 = Memi[xe+j-1] + if (IS_INDEFI(i1) || IS_INDEFI(i2)) { + isum = INDEFI + break + } else + isum = isum + (i2 - i1) + } + } + + call mfree (xs, TY_INT) + call mfree (xe, TY_INT) + call imaddi (im, Memc[pname], isum) + } + } + + call sfree (sp) +end diff --git a/sys/imio/iki/qpf/qpfwfilter.x b/sys/imio/iki/qpf/qpfwfilter.x new file mode 100644 index 00000000..e521cbc6 --- /dev/null +++ b/sys/imio/iki/qpf/qpfwfilter.x @@ -0,0 +1,53 @@ +include "qpf.h" + +# QPF_WFILTER -- Record the QPIO filter used to generate an image as a series +# of FITS cards in the image header. Note: excessively long filters are +# truncated to avoid overfilling the image header. + +procedure qpf_wfilter (qpf, im) + +pointer qpf #I QPF descriptor +pointer im #I image descriptor + +int nchars, nleft, index +pointer io, sp, bp, ip, kw, strval +errchk qpio_getfilter, impstr +int qpio_getfilter() + +begin + io = QPF_IO(qpf) + if (io == NULL) + return + + call smark (sp) + call salloc (kw, SZ_KWNAME, TY_CHAR) + call salloc (bp, SZ_MAXFILTER, TY_CHAR) + call salloc (strval, SZ_BIGSTR, TY_CHAR) + + # Get the filter as as string from QPIO. + nchars = qpio_getfilter (io, Memc[bp], SZ_MAXFILTER) + + # If the filter is longer than our string buffer, write a "..." at + # the end of the filter to indicate that it is being truncated. + + if (nchars == SZ_MAXFILTER) + call strcpy ("...", Memc[bp+nchars-3], 3) + + index = 1 + ip = bp + + # Output a series of QPFILTnn cards to record the full filter. + for (nleft = nchars; nleft > 0; nleft = nleft - SZ_BIGSTR) { + call strcpy (Memc[ip], Memc[strval], SZ_BIGSTR) + call sprintf (Memc[kw], SZ_KWNAME, "QPFILT%02d") + call pargi (index) + iferr (call imaddf (im, Memc[kw], "c")) + ; + call impstr (im, Memc[kw], Memc[strval]) + + ip = ip + SZ_BIGSTR + index = index + 1 + } + + call sfree (sp) +end diff --git a/sys/imio/iki/qpf/zfioqp.x b/sys/imio/iki/qpf/zfioqp.x new file mode 100644 index 00000000..0e1c38ff --- /dev/null +++ b/sys/imio/iki/qpf/zfioqp.x @@ -0,0 +1,189 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> +include <imhdr.h> +include <imio.h> +include <fio.h> +include <qpioset.h> +include "qpf.h" + +# ZFIOQP -- QPF virtual file driver. This driver presents to the caller a +# virtual file space containing a two dimensional array of type short or int +# pixels, wherein each "pixel" is a count of the number of events from a +# QPOE event list which map into that pixel. An i/o request results in +# runtime filtering and sampling of the event list, mapping each event which +# passes the filter into the corresponding output pixel, and incrementing the +# value of that pixel to count the event. + +# QPFZOP -- Open the file driver for i/o on the QPIO descriptor opened at +# qpf_open time. + +procedure qpfzop (pkfn, mode, status) + +char pkfn[ARB] #I packed virtual filename from FIO +int mode #I file access mode (ignored) +int status #O output status - i/o channel if successful + +int ip +pointer sp, fn, qpf +int ctoi() + +begin + call smark (sp) + call salloc (fn, SZ_FNAME, TY_CHAR) + + # The QPF descriptor is passed encoded in the pseudo filename as + # "QPFxxxx" (decimal). Extract this and return it as the i/o + # channel for the driver. + + ip = 4 + call strupk (pkfn, Memc[fn], SZ_FNAME) + if (ctoi (Memc[fn], ip, qpf) <= 0) + status = ERR + else + status = qpf + + QPF_IOSTAT(qpf) = 0 + call sfree (sp) +end + + +# QPFZCL -- Close the QPF binary file driver. + +procedure qpfzcl (chan, status) + +int chan #I QPF i/o channel +int status #O output status + +begin + status = OK +end + + +# QPFZRD -- Read a segment of the virtual pixel array into the output buffer, +# i.e., zero the output buffer and sample the event list, accumulating counts +# in the output array. + +procedure qpfzrd (chan, obuf, nbytes, boffset) + +int chan #I QPF i/o channel +char obuf[ARB] #O output buffer +int nbytes #I nbytes to be read +int boffset #I file offset at which read commences + +pointer qpf, im, io +int vs[2], ve[2] +real xblock, yblock +int szb_pixel, ncols, pixel, nev, xoff, yoff +int qpio_readpixs(), qpio_readpixi() + +include <szpixtype.inc> + +begin + qpf = chan + im = QPF_IM(qpf) + io = QPF_IO(qpf) + + xblock = QPF_XBLOCK(qpf) + yblock = QPF_YBLOCK(qpf) + ncols = IM_PHYSLEN(im,1) + xoff = QPF_VS(qpf,1) + yoff = QPF_VS(qpf,2) + szb_pixel = pix_size[IM_PIXTYPE(im)] * SZB_CHAR + + # Convert boffset, nbytes to vs, ve. + pixel = (boffset - 1) / szb_pixel + vs[1] = (mod (pixel, ncols)) * xblock + xoff + vs[2] = (pixel / ncols) * yblock + yoff + + pixel = (boffset-1 + nbytes - szb_pixel) / szb_pixel + ve[1] = (mod (pixel, ncols)) * xblock + (xblock-1) + xoff + ve[2] = (pixel / ncols) * yblock + (yblock-1) + yoff + + # Call readpix to sample image into the output buffer. Zero the buffer + # first since the read is additive. + + call aclrc (obuf, nbytes / SZB_CHAR) + iferr { + switch (IM_PIXTYPE(im)) { + case TY_SHORT: + nev = qpio_readpixs (io, obuf, vs, ve, 2, xblock, yblock) + case TY_INT: + nev = qpio_readpixi (io, obuf, vs, ve, 2, xblock, yblock) + } + } then { + QPF_IOSTAT(qpf) = ERR + } else + QPF_IOSTAT(qpf) = nbytes +end + + +# QPFZWR -- Write to the virtual pixel array. QPF permits only read-only +# access, but we ignore write requests, so return OK and do nothing if this +# routine is called. + +procedure qpfzwr (chan, ibuf, nbytes, boffset) + +int chan #I QPF i/o channel +char ibuf[ARB] #O datg buffer +int nbytes #I nbytes to be written +int boffset #I file offset to write at + +pointer qpf + +begin + qpf = chan + QPF_IOSTAT(qpf) = nbytes +end + + +# QPFZWT -- Return the number of virtual bytes transferred in the last i/o +# request. + +procedure qpfzwt (chan, status) + +int chan #I QPF i/o channel +int status #O i/o channel status + +pointer qpf + +begin + qpf = chan + status = QPF_IOSTAT(qpf) +end + + +# QPFZST -- Query device/file parameters. + +procedure qpfzst (chan, param, value) + +int chan #I QPF i/o channel +int param #I parameter to be returned +int value #O parameter value + +pointer qpf, im, io +int szb_pixel, npix +int qpio_stati() + +include <szpixtype.inc> + +begin + qpf = chan + im = QPF_IM(qpf) + io = QPF_IO(qpf) + npix = IM_PHYSLEN(im,1) * IM_PHYSLEN(im,2) + szb_pixel = pix_size[IM_PIXTYPE(im)] * SZB_CHAR + + switch (param) { + case FSTT_BLKSIZE: + value = 1 + case FSTT_FILSIZE: + value = npix * szb_pixel + case FSTT_OPTBUFSIZE: + value = min (npix*szb_pixel, qpio_stati(io,QPIO_OPTBUFSIZE)) + case FSTT_MAXBUFSIZE: + value = npix * szb_pixel + default: + value = ERR + } +end diff --git a/sys/imio/iki/stf/README b/sys/imio/iki/stf/README new file mode 100644 index 00000000..5540110b --- /dev/null +++ b/sys/imio/iki/stf/README @@ -0,0 +1,300 @@ +IKI/STF -- IKI kernel for the STScI SDAS/GEIS image format. This format stores +images in a format which resembles FITS group format. A GROUP FORMAT IMAGE is +a set of one or more images, all of which are the same size, dimension, and +datatype, and which share a common FITS header. The individual images in a +group each has a binary GROUP PARAMETER BLOCK (GPB). The image and associated +group parameter block are commonly referred to as a GROUP. A group format +image consists of two files, the FITS format header file for the group, +and the pixel file containing the image data and GPBs. + + +1. Typical STF group format FITS image header (imname.hhh) + + SIMPLE = F / Standard STF keywords + BITPIX = 32 + DATATYPE= 'REAL*4 ' + NAXIS = 2 + NAXIS1 = 512 + NAXIS2 = 512 + GROUPS = T + PSIZE = 512 + GCOUNT = 1 + PCOUNT = 12 + + PTYPE1 = 'DATAMIN ' / Define binary group params + PSIZE1 = 32 + PDTYPE1 = 'REAL*4 ' + (etc, for a total of 3*PCOUNT entries) + + (special keywords and HISTORY cards) + + +2. Pixel file format (imname.hhd) (byte stream, no alignment, no header) + + [1].pixels + [1].group parameter block + [2].pixels + [2].group parameter block + ... + [GCOUNT].pixels + [GCOUNT].group parameter block + + +The chief problems with this format are that the FITS format header can contain +only parameters which pertain to the group as a whole, while the format of the +GPBs is fixed at image creation time. Images may be neither deleted from nor +added to a group. It is possible for parameters in the FITS header to have +the same names as parameters in the GPBs. Multiple entries for the same +keyword may appear in the FITS header and the format does not define how +these are to be handled. Although the format is general enough to support +any datatype pixels, in practice only REAL*4 can be used as the SDAS software +maps the pixfile directly into virtual memory. + +CAVEAT -- This is an awkward interface and some liberties have been taken in +the code (hidden, subtle semantics, etc.). At least we were able to confine +the bad code to this one directory; any problems can be fixed without any +changes to the rest of IMIO. All of this low level code is expected to be +thrown out when IMIO is cut over onto DBIO (the upcoming IRAF database +interface). + + +IKI/STF Pseudocode +---------------------------- + +1. Data structures: + + 1.1 IMIO image descriptor + header, pixel file descriptors + pointer to additional kernel descriptor, if any + index of IKI kernel in use + pathnames of header, pixel files + IM_NDIM, IM_LEN, etc., physical image parameters + + 1.2 STF image descriptor + Pointed to by IM_KDES field of IMIO descriptor. + Contains values of all reserved fields of STF image header, + some of which duplicate values in IMIO descriptor. + Group, gcount, size of a group in pixfile, description of + the group parameter block, i.e., for each parameter, + the offset, datatype type, name, length if array, etc. + + 1.3 IMIO user area (FITS cards) + While an image is open, the first few cards in the user area + contain the FITS encoded group parameters. + The remainder of the user area contains an exact image of + all non-reserved keyword cards found in the STF image + header (or in the header of some other type of image + when making a new_copy of an image stored in some other + format). + + +2. Major Procedures + +procedure open_image + +begin + if (mode is not new_image or new_copy) { + open_existing_image + return + } + + We are opening a new_image or new_copy image. The problem here is + that the new image might be a group within an existing group format + image. This ambiguity is resolved by a simple test on the group + index, rather than by a context dependent test on the existence of + the group format image. If the mode is new_whatever and the group + is 1, a new group format image is created, else if the group is > 1, + the indicated group is initialized in an existing group format image. + + if (group > 1) { + We are opening a new group within an existing group format image. + + Call open_existing_image to open the group without reading the + group parameter block, which has not yet been initialized. + + if (mode is new_image) + initialize GPB to pixel coords + else if (mode is new_copy) + copy old GPB to new image; transform coords if necessary + + Note that when opening a new copy of an existing image as a new + group within a group format image, it is not clear what to do + with the FITS header of the old image. Our solution is to ignore + it, and retain only the GPB, the only part of the old header + pertaining directly to the group being accessed. + + } else if (opening group 1 of a new image) { + We are creating a new group format image. + + if (mode is new_image) + open_new_image + else + open_new_copy + } +end + + +procedure open_existing_image + +begin + Allocate STF descriptor, save pointer in imio descriptor. + Open image header. + + Read header: + process reserved cards into STF descriptor + spool other cards + + Load group data block from pixfile, get datamin/datamax: + if (there is a gdb) { + open pixfile + read gdb into buffer + for (each param in gdb) { + set up parameter descriptor + format FITS card and put in imio user area + } + } + + fetch datamin, datamax from user area + + Set IM_MIN, IM_MAX, IM_LIMTIME from DATAMIN, DATAMAX. + Mark end of user area. + Copy spooled cards to user area. + (increase size of user area if necessary) + + Call imioff to set up imio pixel offset parameters +end + + +procedure open_new_image + +begin + Upon entry, the imio iminie procedure has already been called to + initialize the imio descriptor for the new image. + + Allocate STF descriptor, save pointer in imio descriptor. + Create header file from template dev$pix.hhh. + Open new image header. + + (At this point the IMIO header fields IM_NDIM, IM_LEN, etc., and + (the STF descriptor fields have not yet been set, and cannot be set + (until the image dimensions have been defined by the high level code. + (imopix() will later have to fix up the remaining header fields and + (set up the default group data block. +end + + +procedure open_new_copy + +begin + Upon entry, the imio immaky procedure has already been called to + copy the old header to the new and initialize the data + dependent fields. This will include the FITS encoded group + parameters in the user area of the old image. + + Allocate STF descriptor, save pointer in imio descriptor. + Create header file from template dev$pix.hhh. + Open new image header. + + Copy the STF descriptor of the old image to the new. Preserve + the parameter marking the end of the GPB area of the old + user area, as we do not want to write these cards when the + header is updated. + + (At this point all header information is set up, except that there + (is no pixel file and the pixfile offsets have not been set. + (Provided the image dimensions do not change, one could simply + (set the pixfile name, call imioff, and do i/o to the image. +end + + +procedure open_pixel_file + +begin + (We are called when the first i/o is done to an image. When writing + (to a new image, the user may change any of the image header attributes + (after the open and before we are called. + + if (pixel file already open) + return + else if (opening existing image) { + open pixel file + return + } + + if (opening a new image) { + Given the values of IM_NDIM and IM_LEN set by the user, set up the + STF descriptor including the default group parameter block. Add + the FITS encoded cards for the GPB to the image header. Mark the + end of the GPB cards, i.e., the start of the real user parameter + area. Ignore IM_PIXTYPE; always open an image of type real since + that is what the SDAS software requires. Set up the WCS to linear + pixel coordinates. + + } else if (opening a new_copy image) { + (The STF descriptor and GPB will already have been set up as a + (copy of the data structures used by the old image. However, + (the user may have changed the values of IM_NDIM and IM_LEN + (since the image was opened, and the value of GCOUNT set when + (the image was opened may be different than that of the old image. + + Transform the coordinate system of the old image to produce the + WCS for the new image, i.e., if an image section was used to + reference the old image. + + Make a new STF descriptor using the values of IM_NDIM and IM_LEN + given, as for a new_image, but using the WCS information for the + new image. The FITS encoded fields in the IMIO user area will be + automatically updated by the IMADD functions, or new cards added + if not present. + + Merge any additional fields from the old STF descriptor into the + new one, e.g., any instrument dependent parameters stored in the + GPB. + + (The STF and FITS encoded user area should now contain a full + (description of the GPB for the new image. + } + + Allocate the pixel file, using the GCOUNT parameter set in the + STF descriptor at stf_open time. + Open the pixel file. + + Set IM_MIN and IM_MAX to zero (not defined). + Call IMIOFF to initialize the pixel offsets. +end + + +procedure update_image_header + +begin + Update the values of DATAMIN, DATAMAX from the IMIO header fields. + + Update the binary GPB in the pixel file from the FITS encoded GPB + in the IMIO user area, using the GPB structure defined in the + STF descriptor. + + Update the STF image header file: + Open a new, empty header file using FMKCOPY and OPEN. + Format and output FITS cards for the reserved header fields, + e.g., SIMPLE, BITPIX, GCOUNT, the GPB information, etc. + Copy the user area to the new header file, excluding the + GPB cards at the beginning of the user area. + Close the new header file and replace the old header file + with the new one via a rename operation. +end + + +procedure close_image + +begin + (We assume that IMIO has already update the image header if such + (is necessary. + + if (pixel file open) + close pixel file + if (header file open) + close header file + + deallocate STF descriptor + (IMIO will deallocate the IMIO descriptor) +end diff --git a/sys/imio/iki/stf/mkpkg b/sys/imio/iki/stf/mkpkg new file mode 100644 index 00000000..b28ace96 --- /dev/null +++ b/sys/imio/iki/stf/mkpkg @@ -0,0 +1,36 @@ +# Make the IKI/STF interface (STScI SDAS/GEIS group format images) + +$checkout libex.a lib$ +$update libex.a +$checkin libex.a lib$ +$exit + +libex.a: + #$set XFLAGS = "$(XFLAGS) -qfx" + #$set XFLAGS = "$(XFLAGS) -/pg" + + stfaccess.x stf.h + stfaddpar.x <imhdr.h> <imio.h> <mach.h> stf.h + stfclose.x stf.h <imhdr.h> <imio.h> + stfcopy.x stf.h <error.h> + stfcopyf.x stf.h + stfctype.x stf.h <ctype.h> + stfdelete.x stf.h <error.h> <imhdr.h> + stfget.x stf.h <ctype.h> + stfhextn.x stf.h <imhdr.h> <imio.h> + stfiwcs.x stf.h <imhdr.h> + stfmerge.x stf.h <imhdr.h> <imio.h> <mach.h> + stfmkpfn.x stf.h + stfnewim.x stf.h <imhdr.h> <imio.h> <mach.h> + stfopen.x stf.h <error.h> <imhdr.h> <imio.h> + stfopix.x stf.h <fset.h> <imhdr.h> <imio.h> <mach.h> + stfordgpb.x stf.h <mach.h> + stfrdhdr.x stf.h <finfo.h> <imhdr.h> <imio.h> <mach.h> + stfreblk.x stf.h <imhdr.h> <imio.h> + stfrename.x stf.h <error.h> + stfrfits.x stf.h <ctype.h> <finfo.h> <fset.h> <imhdr.h> <imio.h> + stfrgpb.x stf.h <imhdr.h> <imio.h> <mach.h> + stfupdhdr.x stf.h <imhdr.h> <imio.h> + stfwfits.x stf.h <error.h> <fio.h> <imhdr.h> <imio.h> + stfwgpb.x stf.h <error.h> <imhdr.h> <imio.h> <mach.h> + ; diff --git a/sys/imio/iki/stf/stf.h b/sys/imio/iki/stf/stf.h new file mode 100644 index 00000000..bf99a07c --- /dev/null +++ b/sys/imio/iki/stf/stf.h @@ -0,0 +1,77 @@ +# STF.H -- IKI/STF internal definitions. + +define HDR_TEMPLATE "dev$pix.hhh" # used by fmkcopy to create new header +define MAX_LENEXTN 3 # max length imagefile extension +define STF_HDRPATTERN "^??h" # class of legal header extensions +define STF_DEFHDREXTN "hhh" # default header file extension +define STF_DEFPIXEXTN "hhd" # default pixel file extension +define ENV_DEFIMTYPE "imtype" # name of environment variable +define STF_MAXDIM 7 # max NAXIS +define MAX_CACHE 5 # max cached header files +define DEF_CACHE 3 # default size of header file cache +define ENV_STFCACHE "stfcache" # environment variable for cache size +define MAX_PCOUNT 99 # max param descriptors +define SZ_DATATYPE 16 # e.g., `REAL*4' +define SZ_KEYWORD 8 # size of a FITS keyword +define SZ_PTYPE 8 # e.g., `CRPIX1' +define SZ_PDTYPE 16 # e.g., `CHAR*8' +define SZ_COMMENT FITS_SZCOMMENT # comment string for GPB card +define SZ_EXTRASPACE (81*32) # extra space for new cards in header + +define FITS_RECLEN 80 # length of a FITS record (card) +define FITS_STARTVALUE 10 # first column of value field +define FITS_ENDVALUE 30 # last column of value field +define FITS_SZVALSTR 21 # nchars in value string +define FITS_SZCOMMENT 50 # max chars in comment, incl. / + +# STF image descriptor, used internally by the STF interface. The required +# header parameters are maintained in this descriptor, everything else is +# simply copied into the user area of the IMIO descriptor. + +define LEN_STFDES (LEN_STFBASE+MAX_PCOUNT*LEN_PDES) +define STF_CACHE STF_BITPIX # cache descriptor starting here +define STF_CACHELEN (33+STF_PCOUNT($1)*LEN_PDES) +define LEN_STFBASE 43 + +define STF_ACMODE Memi[$1] # image access mode +define STF_NEWIMAGE Memi[$1+1] # creating entire new STF format image? +define STF_GROUP Memi[$1+2] # group to be accessed +define STF_SZGROUP Memi[$1+3] # size of image+hdr in pixfile, chars +define STF_PFD Memi[$1+4] # pixfile file descriptor +define STF_GRARG Memi[$1+5] # group index given in image name + # (extra space) +define STF_BITPIX Memi[$1+10] # bits per pixel +define STF_NAXIS Memi[$1+11] # number of axes in image +define STF_GROUPS Memi[$1+12] # group format? +define STF_GCOUNT Memi[$1+13] # number of groups in STF image +define STF_PSIZE Memi[$1+14] # size of GPB, bits +define STF_PCOUNT Memi[$1+15] # number of parameters in GPB +define STF_DATATYPE Memc[P2C($1+16)]# datatype string +define STF_LENAXIS Memi[$1+35+$2-1]# 35:41 = [7] max +define STF_PDES (($1)+43+((($2)-1)*LEN_PDES)) + +# GPB Parameter descriptor. +define LEN_PDES 81 +define P_OFFSET Memi[$1] # struct offset of parameter +define P_SPPTYPE Memi[$1+1] # SPP datatype of parameter +define P_LEN Memi[$1+2] # number of elements +define P_PSIZE Memi[$1+3] # field size, bits +define P_PTYPEP (P2C($1+4)) # pointer to parameter name +define P_PTYPE Memc[P2C($1+4)] # parameter name +define P_PDTYPE Memc[P2C($1+13)]# datatype string +define P_COMMENT Memc[P2C($1+30)]# comment string + +# Reserved FITS keywords known to this code. +define KW_BITPIX 1 +define KW_DATATYPE 2 +define KW_END 3 +define KW_GCOUNT 4 +define KW_GROUPS 5 +define KW_NAXIS 6 +define KW_NAXISN 7 +define KW_PCOUNT 8 +define KW_PDTYPE 9 +define KW_PSIZE 10 +define KW_PSIZEN 11 +define KW_PTYPE 12 +define KW_SIMPLE 13 diff --git a/sys/imio/iki/stf/stfaccess.x b/sys/imio/iki/stf/stfaccess.x new file mode 100644 index 00000000..40907c69 --- /dev/null +++ b/sys/imio/iki/stf/stfaccess.x @@ -0,0 +1,58 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "stf.h" + +# STF_ACCESS -- Test the accessibility or existence of an existing image, or +# the legality of the name of a new image. + +procedure stf_access (kernel, root, extn, acmode, status) + +int kernel #I IKI kernel +char root[ARB] #I root filename +char extn[ARB] #I extension (SET on output if none specified) +int acmode #I access mode (0 to test only existence) +int status #O return value + +int i +pointer sp, fname, kextn +int access(), iki_validextn(), iki_getextn(), btoi() + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + call salloc (kextn, MAX_LENEXTN, TY_CHAR) + + # If new image, test only the legality of the given extension. + # This is used to select a kernel given the imagefile extension. + + if (acmode == NEW_IMAGE || acmode == NEW_COPY) { + status = btoi (iki_validextn (kernel, extn) > 0) + call sfree (sp) + return + } + + status = NO + + # If no extension was given, look for a file with the default + # extension, and return the actual extension if an image with the + # default extension is found. + + if (extn[1] == EOS) { + do i = 1, ARB { + if (iki_getextn (kernel, i, Memc[kextn], MAX_LENEXTN) <= 0) + break + call iki_mkfname (root, Memc[kextn], Memc[fname], SZ_PATHNAME) + if (access (Memc[fname], acmode, 0) == YES) { + call strcpy (Memc[kextn], extn, MAX_LENEXTN) + status = YES + break + } + } + } else if (iki_validextn (kernel, extn) == kernel) { + call iki_mkfname (root, extn, Memc[fname], SZ_PATHNAME) + if (access (Memc[fname], acmode, 0) == YES) + status = YES + } + + call sfree (sp) +end diff --git a/sys/imio/iki/stf/stfaddpar.x b/sys/imio/iki/stf/stfaddpar.x new file mode 100644 index 00000000..65a90f80 --- /dev/null +++ b/sys/imio/iki/stf/stfaddpar.x @@ -0,0 +1,94 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> +include <mach.h> +include "stf.h" + +# STF_ADDPAR -- Encode a parameter in FITS format and add it to the FITS format +# IMIO user area; initialize the entry for the parameter in the GPB descriptor +# as well. + +procedure stf_addpar (im, pname, dtype, plen, pval, pno) + +pointer im #I image descriptor +char pname[ARB] #I parameter name +int dtype #I SPP datatype of parameter +int plen #I length (> 1 if array) +char pval[ARB] #I string encoded initial parameter value +int pno #U parameter number + +bool bval +real rval +double dval +short sval +long lval +pointer pp, stf + +bool initparam +int ival, ip, junk +int ctoi(), ctor(), ctod(), imaccf() +errchk imadds, imaddl, imaddr, imaddd, imastr + +begin + stf = IM_KDES(im) + pp = STF_PDES(stf,pno) + ip = 1 + + call strcpy (pname, P_PTYPE(pp), SZ_PTYPE) + + # Initialize the parameter only if not already defined in header. + initparam = (imaccf (im, pname) == NO) + + switch (dtype) { + case TY_BOOL: + call strcpy ("LOGICAL*4", P_PDTYPE(pp), SZ_PDTYPE) + P_PSIZE(pp) = plen * SZ_BOOL * SZB_CHAR * NBITS_BYTE + if (initparam) { + bval = (pval[1] == 'T') + call imaddb (im, P_PTYPE(pp), bval) + } + case TY_SHORT: + call strcpy ("INTEGER*2", P_PDTYPE(pp), SZ_PDTYPE) + P_PSIZE(pp) = plen * SZ_SHORT * SZB_CHAR * NBITS_BYTE + if (initparam) { + junk = ctoi (pval, ip, ival) + sval = ival + call imadds (im, P_PTYPE(pp), sval) + } + case TY_LONG: + call strcpy ("INTEGER*4", P_PDTYPE(pp), SZ_PDTYPE) + P_PSIZE(pp) = plen * SZ_LONG * SZB_CHAR * NBITS_BYTE + if (initparam) { + junk = ctoi (pval, ip, ival) + lval = ival + call imaddl (im, P_PTYPE(pp), lval) + } + case TY_REAL: + call strcpy ("REAL*4", P_PDTYPE(pp), SZ_PDTYPE) + P_PSIZE(pp) = plen * SZ_REAL * SZB_CHAR * NBITS_BYTE + if (initparam) { + junk = ctor (pval, ip, rval) + call imaddr (im, P_PTYPE(pp), rval) + } + case TY_DOUBLE: + call strcpy ("REAL*8", P_PDTYPE(pp), SZ_PDTYPE) + P_PSIZE(pp) = plen * SZ_DOUBLE * SZB_CHAR * NBITS_BYTE + if (initparam) { + junk = ctod (pval, ip, dval) + call imaddd (im, P_PTYPE(pp), dval) + } + default: + call sprintf (P_PDTYPE(pp), SZ_PDTYPE, "CHARACTER*%d") + call pargi (plen) + P_PSIZE(pp) = plen * NBITS_BYTE + if (initparam) + call imastr (im, P_PTYPE(pp), pval) + } + + P_OFFSET(pp) = 0 + P_SPPTYPE(pp) = dtype + P_LEN(pp) = plen + + pno = pno + 1 +end diff --git a/sys/imio/iki/stf/stfclose.x b/sys/imio/iki/stf/stfclose.x new file mode 100644 index 00000000..89981578 --- /dev/null +++ b/sys/imio/iki/stf/stfclose.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> +include "stf.h" + +# STF_CLOSE -- Close an STF format image. There is little for us to do, since +# IMIO will already have updated the header if necessary and flushed any pixel +# output. Neither do we have to deallocate the IMIO descriptor, since it was +# allocated by IMIO. + +procedure stf_close (im, status) + +pointer im # image descriptor +int status + +pointer stf +errchk close + +begin + stf = IM_KDES(im) + + # Close the pixel file and header file, if open. + if (STF_PFD(stf) != NULL) + call close (STF_PFD(stf)) + if (IM_HFD(im) != NULL) + call close (IM_HFD(im)) + + # Deallocate the STF descirptor. + call mfree (IM_KDES(im), TY_STRUCT) + status = OK +end diff --git a/sys/imio/iki/stf/stfcopy.x b/sys/imio/iki/stf/stfcopy.x new file mode 100644 index 00000000..e8643600 --- /dev/null +++ b/sys/imio/iki/stf/stfcopy.x @@ -0,0 +1,43 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include "stf.h" + +# STF_COPY -- Copy an image. A special operator is provided for fast, blind +# copies of entire images. + +procedure stf_copy (kernel, oroot, oextn, nroot, nextn, status) + +int kernel #I IKI kernel +char oroot[ARB] # old image root name +char oextn[ARB] # old image extn +char nroot[ARB] # new image root name +char nextn[ARB] # old image extn +int status + +pointer sp +pointer ohdr_fname, opix_fname, nhdr_fname, npix_fname + +begin + call smark (sp) + call salloc (ohdr_fname, SZ_PATHNAME, TY_CHAR) + call salloc (opix_fname, SZ_PATHNAME, TY_CHAR) + call salloc (nhdr_fname, SZ_PATHNAME, TY_CHAR) + call salloc (npix_fname, SZ_PATHNAME, TY_CHAR) + + # Generate filenames. + call iki_mkfname (oroot, oextn, Memc[ohdr_fname], SZ_PATHNAME) + call iki_mkfname (nroot, nextn, Memc[nhdr_fname], SZ_PATHNAME) + + call stf_mkpixfname (oroot, oextn, Memc[opix_fname], SZ_PATHNAME) + call stf_mkpixfname (nroot, nextn, Memc[npix_fname], SZ_PATHNAME) + + # If the header cannot be copied, leave the pixfile alone. + iferr (call fcopy (Memc[ohdr_fname], Memc[nhdr_fname])) + call erract (EA_WARN) + else iferr (call fcopy (Memc[opix_fname], Memc[npix_fname])) + call erract (EA_WARN) + + call sfree (sp) + status = OK +end diff --git a/sys/imio/iki/stf/stfcopyf.x b/sys/imio/iki/stf/stfcopyf.x new file mode 100644 index 00000000..7402c879 --- /dev/null +++ b/sys/imio/iki/stf/stfcopyf.x @@ -0,0 +1,92 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "stf.h" + +define NKW 4 # number of reserved header keywords + + +# STF_COPYFITS -- Copy the spooled FITS header, separating out the GPB cards +# and returning either or both types of cards on the two output streams. + +procedure stf_copyfits (stf, spool, gpb, user) + +pointer stf #I pointer to STF descriptor +int spool #I spooled header to read +int gpb #I stream to receive GPB cards, or NULL +int user #I stream to receive user cards, or NULL + +bool keyword +int p_ch[MAX_PCOUNT+NKW] +pointer p_len[MAX_PCOUNT+NKW] +pointer p_namep[MAX_PCOUNT+NKW] +int delim, ch, npars, ngpbpars, i +pointer sp, lbuf, sbuf, pp, op, kw[NKW] +int strncmp(), getline(), strlen(), gstrcpy() +errchk getline, putline + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + call salloc (sbuf, SZ_LINE, TY_CHAR) + + # The following reserved keywords describing the GPB are added to + # the user area by stf_rdheader, and must be filtered out along with + # the group parameters. Since the number of reserved or group + # parameters is normally small (only a dozen or so typically) a + # simple 1 character - 2 thread hashing scheme is probably faster, + # and certainly simpler, than a full hash table keyword lookup. + + op = sbuf + npars = NKW + kw[1] = op; op = op + gstrcpy ("GROUPS", Memc[op], ARB) + 1 + kw[2] = op; op = op + gstrcpy ("GCOUNT", Memc[op], ARB) + 1 + kw[3] = op; op = op + gstrcpy ("PCOUNT", Memc[op], ARB) + 1 + kw[4] = op; op = op + gstrcpy ("PSIZE", Memc[op], ARB) + 1 + + do i = 1, npars { + p_namep[i] = kw[i] + p_len[i] = strlen(Memc[kw[i]]) + p_ch[i] = Memc[kw[i]+2] + } + + # Add the GPB parameters to the list of group related parameters. + ngpbpars = min (MAX_PCOUNT, STF_PCOUNT(stf)) + do i = 1, ngpbpars { + npars = npars + 1 + pp = STF_PDES(stf,i) + p_namep[npars] = P_PTYPEP(pp) + p_len[npars] = strlen(P_PTYPE(pp)) + p_ch[npars] = Memc[p_namep[npars]+2] + } + + # Determine the type of each card and copy it to the appropriate + # output stream. + + while (getline (spool, Memc[lbuf]) != EOF) { + # Does this user card redefine a reserved keyword? + keyword = false + ch = Memc[lbuf+2] + do i = 1, npars { + if (ch != p_ch[i]) + next + delim = Memc[lbuf+p_len[i]] + if (delim != ' ' && delim != '=') + next + if (strncmp (Memc[lbuf], Memc[p_namep[i]], p_len[i]) == 0) { + keyword = true + break + } + } + + # Copy the card to the appropriate stream. + if (keyword) { + if (gpb != NULL) + call putline (gpb, Memc[lbuf]) + } else { + if (user != NULL) + call putline (user, Memc[lbuf]) + } + } + + call sfree (sp) +end diff --git a/sys/imio/iki/stf/stfctype.x b/sys/imio/iki/stf/stfctype.x new file mode 100644 index 00000000..9c48f65a --- /dev/null +++ b/sys/imio/iki/stf/stfctype.x @@ -0,0 +1,85 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <ctype.h> +include "stf.h" + +# STF_CTYPE -- Determine the type of a FITS card. STF recognizes only those +# cards which define the image format and the group parameter block. + +int procedure stf_ctype (card, index) + +char card[ARB] #I FITS card (or keyword) +int index #O index number, if any + +int ch1, ch2, ip +int strncmp(), ctoi() + +begin + ch1 = card[1] + ch2 = card[2] + + # The set of keywords is fixed and small, so a simple brute force + # recognizer is about as good as anything. + + if (ch1 == 'B') { + if (ch2 == 'I') + if (strncmp (card, "BITPIX ", 8) == 0) + return (KW_BITPIX) # BITPIX + } else if (ch1 == 'D') { + if (ch2 == 'A') + if (strncmp (card, "DATATYPE", 8) == 0) + return (KW_DATATYPE) # DATATYPE + } else if (ch1 == 'E') { + if (ch2 == 'N') + if (card[3] == 'D' && card[4] == ' ') + return (KW_END) # END card + } else if (ch1 == 'G') { + if (ch2 == 'C') { + if (strncmp (card, "GCOUNT ", 8) == 0) + return (KW_GCOUNT) # GCOUNT + } else if (ch2 == 'R') { + if (strncmp (card, "GROUPS ", 8) == 0) + return (KW_GROUPS) # GROUPS + } + } else if (ch1 == 'N') { + if (ch2 == 'A') + if (strncmp (card, "NAXIS", 5) == 0) + if (card[6] == ' ') + return (KW_NAXIS) # NAXIS + else if (IS_DIGIT(card[6])) { + index = TO_INTEG(card[6]) + return (KW_NAXISN) # NAXISn + } + } else if (ch1 == 'P') { + if (ch2 == 'C') { + if (strncmp (card, "PCOUNT ", 8) == 0) + return (KW_PCOUNT) # PCOUNT + } else if (ch2 == 'D') { + if (strncmp (card, "PDTYPE", 6) == 0) { + ip = 7 + if (ctoi (card, ip, index) > 0) + return (KW_PDTYPE) # PDTYPEn + } + } else if (ch2 == 'S') { + if (strncmp (card, "PSIZE", 5) == 0) { + ip = 6 + if (card[ip] == ' ') + return (KW_PSIZE) + else if (ctoi (card, ip, index) > 0) + return (KW_PSIZEN) # PSIZEn + } + } else if (ch2 == 'T') { + if (strncmp (card, "PTYPE", 5) == 0) { + ip = 6 + if (ctoi (card, ip, index) > 0) + return (KW_PTYPE) # PTYPEn + } + } + } else if (ch1 == 'S') { + if (ch2 == 'I') + if (strncmp (card, "SIMPLE ", 8) == 0) + return (KW_SIMPLE) # SIMPLE + } + + return (ERR) +end diff --git a/sys/imio/iki/stf/stfdelete.x b/sys/imio/iki/stf/stfdelete.x new file mode 100644 index 00000000..dd319f12 --- /dev/null +++ b/sys/imio/iki/stf/stfdelete.x @@ -0,0 +1,40 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include <imhdr.h> +include "stf.h" + +# STF_DELETE -- Delete an image. A special operator is required since the +# image is stored as two files. + +procedure stf_delete (kernel, root, extn, status) + +int kernel #I IKI kernel +char root[ARB] #I root filename +char extn[ARB] #U header file extension +int status #O return value + +pointer sp +pointer hdr_fname, pix_fname +int access() + +begin + call smark (sp) + call salloc (hdr_fname, SZ_PATHNAME, TY_CHAR) + call salloc (pix_fname, SZ_PATHNAME, TY_CHAR) + + # Generate filename. + call iki_mkfname (root, extn, Memc[hdr_fname], SZ_PATHNAME) + call stf_mkpixfname (root, extn, Memc[pix_fname], SZ_PATHNAME) + + # If the header cannot be deleted, leave the pixfile alone. + iferr (call delete (Memc[hdr_fname])) + call erract (EA_WARN) + else if (access (Memc[pix_fname],0,0) == YES) { + iferr (call delete (Memc[pix_fname])) + call erract (EA_WARN) + } + + status = OK + call sfree (sp) +end diff --git a/sys/imio/iki/stf/stfget.x b/sys/imio/iki/stf/stfget.x new file mode 100644 index 00000000..bacbc8d7 --- /dev/null +++ b/sys/imio/iki/stf/stfget.x @@ -0,0 +1,97 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <ctype.h> +include "stf.h" + +# STF_GETI -- Return the integer value of a FITS encoded card. + +procedure stf_geti (card, ival) + +char card[ARB] # card to be decoded +int ival # receives integer value + +int ip, ctoi() +char sval[FITS_SZVALSTR] + +begin + call stf_gets (card, sval, FITS_SZVALSTR) + ip = 1 + if (ctoi (sval, ip, ival) <= 0) + ival = 0 +end + + +# STF_GETB -- Return the boolean/integer value of a FITS encoded card. + +procedure stf_getb (card, bval) + +char card[ARB] # card to be decoded +int bval # receives YES/NO + +char sval[FITS_SZVALSTR] + +begin + call stf_gets (card, sval, FITS_SZVALSTR) + if (sval[1] == 'T') + bval = YES + else + bval = NO +end + + +# STF_GETS -- Get the string value of a FITS encoded card. Strip leading +# and trailing whitespace and any quotes. + +procedure stf_gets (card, outstr, maxch) + +char card[ARB] # FITS card to be decoded +char outstr[ARB] # output string to receive parameter value +int maxch + +int ip, op +int ctowrd(), strlen() + +begin + ip = FITS_STARTVALUE + if (ctowrd (card, ip, outstr, maxch) > 0) { + # Strip trailing whitespace. + op = strlen (outstr) + while (op > 0 && (IS_WHITE(outstr[op]) || outstr[op] == '\n')) + op = op - 1 + outstr[op+1] = EOS + } else + outstr[1] = EOS +end + + +# STF_GETCMT -- Get the comment field of a FITS encoded card. + +procedure stf_getcmt (card, comment, maxch) + +char card[ARB] #I FITS card to be decoded +char comment[ARB] #O output string to receive comment +int maxch #I max chars out + +int ip, op +int lastch + +begin + # Find the slash which marks the beginning of the comment field. + ip = FITS_ENDVALUE + 1 + while (card[ip] != EOS && card[ip] != '\n' && card[ip] != '/') + ip = ip + 1 + + # Copy the comment to the output string, omitting the /, any + # trailing blanks, and the newline. + + lastch = 0 + do op = 1, maxch { + if (card[ip] == EOS) + break + ip = ip + 1 + comment[op] = card[ip] + if (card[ip] > ' ') + lastch = op + } + comment[lastch+1] = EOS +end diff --git a/sys/imio/iki/stf/stfhextn.x b/sys/imio/iki/stf/stfhextn.x new file mode 100644 index 00000000..45e89f7a --- /dev/null +++ b/sys/imio/iki/stf/stfhextn.x @@ -0,0 +1,39 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> +include "stf.h" + + +# STF_GETHDREXTN -- Get the default header file extension. + +procedure stf_gethdrextn (im, o_im, acmode, outstr, maxch) + +pointer im, o_im #I image descriptors +int acmode #I access mode +char outstr[maxch] #O receives header extension +int maxch #I max chars out + +bool inherit +int kernel, old_kernel +int fnextn(), iki_getextn(), iki_getpar() + +begin + # Use the same extension as the input file if this is a new copy + # image of the same type as the input and inherit is enabled. + # If we have to get the extension using iki_getextn, the default + # extension for a new image is the first extension defined (index=1). + + kernel = IM_KERNEL(im) + + old_kernel = 0 + if (acmode == NEW_COPY && o_im != NULL) + old_kernel = IM_KERNEL(o_im) + + inherit = (iki_getpar ("inherit") == YES) + if (inherit && acmode == NEW_COPY && kernel == old_kernel) { + if (fnextn (IM_HDRFILE(im), outstr, maxch) <= 0) + call strcpy (STF_DEFHDREXTN, outstr, maxch) + } else if (iki_getextn (kernel, 1, outstr, maxch) < 0) + call strcpy (STF_DEFHDREXTN, outstr, maxch) +end diff --git a/sys/imio/iki/stf/stfiwcs.x b/sys/imio/iki/stf/stfiwcs.x new file mode 100644 index 00000000..415b9a76 --- /dev/null +++ b/sys/imio/iki/stf/stfiwcs.x @@ -0,0 +1,60 @@ +include <imhdr.h> +include "stf.h" + +# STF_INITWCS -- Check for an unitialized WCS and set up a unitary pixel +# WCS in this case. + +procedure stf_initwcs (im) + +pointer im #I image descriptor + +real v +int ndim, i, j +bool have_wcs, wcsok +char pname[SZ_KEYWORD] +bool fp_equalr() +real imgetr() + +begin + ndim = IM_NDIM(im) + have_wcs = false + wcsok = false + + # Scan the header to determine if we have any WCS information (assume + # there is a WCS if any CDi_j cards are found) and if it has been + # initialized (at least one matrix element is nonzero). Note that + # we are checking only to see if the WCS has been initialized, not + # if it is a valid WCS. + + do j = 1, ndim { + do i = 1, ndim { + call sprintf (pname, SZ_KEYWORD, "CD%d_%d") + call pargi (i) + call pargi (j) + ifnoerr (v = imgetr (im, pname)) { + have_wcs = true + if (!fp_equalr (v, 0.0)) { + wcsok = true + break + } + } + } + if (wcsok) + break + } + + # If we found some WCS information and the CD matrix is zero, init + # the WCS. + + if (have_wcs && !wcsok) + do i = 1, ndim { + call sprintf (pname, SZ_KEYWORD, "CTYPE%d") + call pargi (i) + call imastr (im, pname, "PIXEL") + + call sprintf (pname, SZ_KEYWORD, "CD%d_%d") + call pargi (i) + call pargi (i) + call imaddr (im, pname, 1.0) + } +end diff --git a/sys/imio/iki/stf/stfmerge.x b/sys/imio/iki/stf/stfmerge.x new file mode 100644 index 00000000..a98ee877 --- /dev/null +++ b/sys/imio/iki/stf/stfmerge.x @@ -0,0 +1,105 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> +include <mach.h> +include "stf.h" + +# STF_MERGEGPB -- Merge the non-reserved parameters from an existing GPB into +# a new GPB; called to construct a new GPB when an image is opened in new-copy +# mode. Since the new copy may not be the same size and dimension as the +# original, the reserved parameters must be set up fresh for the new copy +# image, i.e., we cannot simply copy them from the old image. Likewise, the +# WCS must be transformed if the new copy image does not geometrically overlay +# the original. +# +# NOTE: no longer called by stf_opix; save this code for future use! +# <dlb--11/4/87> + +procedure stf_mergegpb (n_im, o_im) + +pointer n_im # new copy image +pointer o_im # image being copied + +bool match +int n_i, o_i, n, ip, axis +int up_psize +pointer sp, cd_pat, n_stf, o_stf, n_pp, o_pp +int strncmp(), strlen(), patmake(), patmatch(), ctoi() + +begin + call smark (sp) + call salloc (cd_pat, SZ_LINE, TY_CHAR) + + # Make a pattern to match the CDa_b parameter names. + if (patmake ("CD[0-9]_[0-9]", Memc[cd_pat], SZ_LINE) < 0) + ; # cannot happen + + n_stf = IM_KDES(n_im) + o_stf = IM_KDES(o_im) + + # Examine each parameter in the old GPB and make an entry for the new + # ones in the new GPB. Note that all we are doing here is defining + # the structure; the GPB data is not physically written until the new + # header is updated on disk. The FITS encoded values for the GPB + # parameters will already have been copied to the user area of the + # new image. + + up_psize = 0 + for (o_i=1; o_i <= STF_PCOUNT(o_stf); o_i=o_i+1) { + o_pp = STF_PDES(o_stf,o_i) + n = strlen (P_PTYPE(o_pp)) + + if (P_PTYPE(o_pp) == 'C') + if (strncmp (P_PTYPE(o_pp), "CRPIX", 5) == 0 || + strncmp (P_PTYPE(o_pp), "CRVAL", 5) == 0 || + strncmp (P_PTYPE(o_pp), "CTYPE", 5) == 0 || + patmatch (P_PTYPE(o_pp), Memc[cd_pat]) > 0) { + + ip = 6 + if (ctoi (P_PTYPE(o_pp), ip, axis) <= 0) + axis = IM_MAXDIM + 1 + if (axis <= STF_NAXIS(n_stf)) + next + } + + # Is there a parameter of the same name in the new descriptor? + match = false + for (n_i=1; n_i <= STF_PCOUNT(n_stf); n_i=n_i+1) { + n_pp = STF_PDES(n_stf,n_i) + if (strncmp (P_PTYPE(o_pp), P_PTYPE(n_pp), n) == 0) { + match = true + break + } + } + + # If there was no match for the parameter, add a definition for + # it to the GPB descriptor for the new image. + + if (!match) { + n = STF_PCOUNT(n_stf) + 1 + if (n > MAX_PCOUNT) + call error (4, "stf_merge: too many group parameters") + + STF_PCOUNT(n_stf) = n + up_psize = up_psize + P_PSIZE(o_pp) + n_pp = STF_PDES(n_stf,n) + + P_SPPTYPE(n_pp) = P_SPPTYPE(o_pp) + P_PSIZE(n_pp) = P_PSIZE(o_pp) + P_LEN(n_pp) = P_LEN(o_pp) + + call strcpy (P_PTYPE(o_pp), P_PTYPE(n_pp), SZ_PTYPE) + call strcpy (P_PDTYPE(o_pp), P_PDTYPE(n_pp), SZ_PDTYPE) + } + } + + # Moved the PSIZE, SZGROUP calculations here to fix error in the + # computation of PSIZE--dlb, 11/2/87 + + STF_PSIZE(n_stf) = STF_PSIZE(n_stf) + up_psize + STF_SZGROUP(n_stf) = STF_SZGROUP(n_stf) + + up_psize / (SZB_CHAR * NBITS_BYTE) + + call sfree (sp) +end diff --git a/sys/imio/iki/stf/stfmkpfn.x b/sys/imio/iki/stf/stfmkpfn.x new file mode 100644 index 00000000..4568efd8 --- /dev/null +++ b/sys/imio/iki/stf/stfmkpfn.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "stf.h" + +# STF_MKPIXFNAME -- Given the root and extn fields of the image header filename, +# construct the pixel file name. The pixel file has the same root name as +# the header and the first two characters of the extension are the same as for +# the header, if a header extension was given. + +procedure stf_mkpixfname (hdr_root, hdr_extn, pixfname, maxch) + +char hdr_root[ARB] # root name of header file +char hdr_extn[ARB] # extension of header file +char pixfname[maxch] # receives pixel filename +int maxch + +int i +char pix_extn[MAX_LENEXTN] + +begin + call strcpy (STF_DEFPIXEXTN, pix_extn, MAX_LENEXTN) + if (hdr_extn[1] != EOS) { + for (i=1; i < MAX_LENEXTN; i=i+1) + pix_extn[i] = hdr_extn[i] + } + + call iki_mkfname (hdr_root, pix_extn, pixfname, maxch) +end diff --git a/sys/imio/iki/stf/stfnewim.x b/sys/imio/iki/stf/stfnewim.x new file mode 100644 index 00000000..3e8a95ed --- /dev/null +++ b/sys/imio/iki/stf/stfnewim.x @@ -0,0 +1,146 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> +include <mach.h> +include "stf.h" + +define NBITS_CHAR (SZB_CHAR * NBITS_BYTE) + + +# STF_NEWIMAGE -- Set up the IMIO/STF descriptor for an image opened with mode +# new_image or new_copy of non-STF images. Note that the parameters GROUP +# and GCOUNT were set earlier by stf_open(). + +procedure stf_newimage (im) + +pointer im # image descriptor + +pointer stf +pointer o_im +long totpix +char pname[SZ_KEYWORD] +int old_kernel, pixtype, bitpix, nbytes, pno, ndim, i, j +errchk stf_addpar +string zero "0" +string one "1" + +include <szpixtype.inc> + +begin + # Get length of axes and datatype from imio descriptor; + # these may be changed by the user between image mapping + # and first i/o to pixfile so we set up the group parameter block + # and size of pixfile on first i/o operation + + stf = IM_KDES(im) + o_im = IM_OHDR(im) + ndim = IM_NDIM(im) + STF_NAXIS(stf) = ndim + do i = 1, ndim + STF_LENAXIS(stf,i) = IM_LEN(im,i) + + # Get datatype for the pixfile; stf_open has set this to datatype + # of template file if it exists, otherwise defaults to real(assuming + # the user hasn't changed it by now) + + pixtype = IM_PIXTYPE(im) + + bitpix = pix_size[pixtype] * NBITS_CHAR + nbytes = bitpix / NBITS_BYTE + + call sprintf (STF_DATATYPE(stf), SZ_DATATYPE, "%s*%d") + switch (pixtype) { + case TY_USHORT: + call pargstr ("UNSIGNED") + case TY_SHORT, TY_LONG, TY_INT: + call pargstr ("INTEGER") + case TY_REAL, TY_DOUBLE: + call pargstr ("REAL") + case TY_COMPLEX: + call pargstr ("COMPLEX") + default: + pixtype = TY_REAL + bitpix = SZ_REAL * NBITS_CHAR + nbytes = bitpix / NBITS_BYTE + call pargstr ("REAL") + } + call pargi (nbytes) + + STF_BITPIX(stf) = bitpix + + # Set the IMIO min/max fields. + + IM_MIN(im) = 0. + IM_MAX(im) = 0. + IM_LIMTIME(im) = 0 + + # For a new copy image(of an already-existing file), DO NOT add group + # parameters to the GPB, unless the original image is not an STF + # image. The following are the "standard" set of datamin/max and the + # FITS coordinate parms which SDAS files are supposed to have. + + if (IM_ACMODE(im) == NEW_COPY && o_im != NULL) + old_kernel = IM_KERNEL(o_im) + + if ((IM_ACMODE(im) == NEW_FILE) || + ((IM_ACMODE(im) == NEW_COPY) && IM_KERNEL(im) != old_kernel)) { + + # Set up the standard STF group parameter block parameters. + STF_GROUPS(stf) = YES + STF_PCOUNT(stf) = 2 + (ndim * 3) + (ndim * ndim) + STF_PSIZE(stf) = 2 * (SZ_REAL * NBITS_CHAR) + # DATAMIN/MAX + ndim * (SZ_DOUBLE * NBITS_CHAR) + # CRVALn + ndim * (SZ_REAL * NBITS_CHAR) + # CRPIXn + ndim * (8 * NBITS_BYTE) + # CTYPEn + (ndim * ndim) * (SZ_REAL * NBITS_CHAR) # CD matrix + + # Free any unneeded space in the STF descriptor. + if (STF_PCOUNT(stf) > 0) { + call realloc (stf, + LEN_STFBASE + STF_PCOUNT(stf)*LEN_PDES, TY_STRUCT) + IM_KDES(im) = stf + } + + # Set up the group data block in the STF descriptor and in + # the IMIO FITS format user area. WARNING--the STF kernel + # is implicitly assuming that the GPB related parameters + # in non-STF format images are at the beginning of the user + # area, if they are present at all. If this is not true + # then the following code will APPEND them to the user area. + # At STScI, non-STF format images are usually made from STF + # images and these parameters are at the beginning of the user + # area in that case. + + pno = 1 + call stf_addpar (im, "DATAMIN", TY_REAL, 1, zero, pno) + call stf_addpar (im, "DATAMAX", TY_REAL, 1, zero, pno) + + do i = 1, ndim { + call sprintf (pname, SZ_KEYWORD, "CRPIX%d"); call pargi (i) + call stf_addpar (im, pname, TY_REAL, 1, zero, pno) + call sprintf (pname, SZ_KEYWORD, "CRVAL%d"); call pargi (i) + call stf_addpar (im, pname, TY_DOUBLE, 1, zero, pno) + call sprintf (pname, SZ_KEYWORD, "CTYPE%d"); call pargi (i) + call stf_addpar (im, pname, TY_CHAR, 8, "PIXEL", pno) + + do j = 1, ndim { + call sprintf (pname, SZ_KEYWORD, "CD%d_%d") + call pargi (j) + call pargi (i) + if (i == j) + call stf_addpar (im, pname, TY_REAL, 1, one, pno) + else + call stf_addpar (im, pname, TY_REAL, 1, zero, pno) + } + } + } + + # Compute the size of each group in the pixel file, in chars. + totpix = IM_LEN(im,1) + do i = 2, ndim + totpix = totpix * IM_LEN(im,i) + + STF_SZGROUP(stf) = totpix * pix_size[IM_PIXTYPE(im)] + + STF_PSIZE(stf) / (SZB_CHAR * NBITS_BYTE) +end diff --git a/sys/imio/iki/stf/stfopen.x b/sys/imio/iki/stf/stfopen.x new file mode 100644 index 00000000..016c557e --- /dev/null +++ b/sys/imio/iki/stf/stfopen.x @@ -0,0 +1,225 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <error.h> +include <imhdr.h> +include <imio.h> +include "stf.h" + +# STF_OPEN -- Open/create an STF group format image. + +procedure stf_open (kernel, im, o_im, + root, extn, ksection, gr_arg, gc_arg, acmode, status) + +int kernel #I IKI kernel +pointer im #I image descriptor +pointer o_im #I other descriptor for NEW_COPY image +char root[ARB] #I root image name +char extn[ARB] #I extension, if any +char ksection[ARB] #I NOT USED +int gr_arg #I index of group to be accessed +int gc_arg #I number of groups in STF image +int acmode #I access mode +int status #O return value + +bool subimage +pointer sp, fname, stf, stf_extn, ua, o_stf +int group, gcount, newimage, gpb, hdr, o_stflen + +bool fnullfile(), envgetb() +int open(), stropen(), access() +errchk stf_initwcs, fmkcopy, calloc, realloc, syserrs +define err_ 91 + +begin + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + call salloc (stf_extn, MAX_LENEXTN, TY_CHAR) + + ua = IM_USERAREA(im) + + # Allocate internal STF image descriptor. + call calloc (stf, LEN_STFDES, TY_STRUCT) + IM_KDES(im) = stf + + group = max (1, gr_arg) + gcount = max (group, gc_arg) + + STF_GRARG(stf) = max (0, gr_arg) + STF_GROUP(stf) = group + STF_GCOUNT(stf) = gcount + STF_ACMODE(stf) = acmode + STF_PFD(stf) = NULL + + # If a nonzero gcount is specified when a new-image or new-copy image + # is opened (e.g., [1/10] we assume that an entire new group format + # image is to be created with the given group count. If neither the + # group or gcount values are specified we assume that a new image is + # to be created. If the gcount field is zero (e.g., [1/0] or just [1]) + # then we assume that the image already exists and that we are being + # asked to rewrite the indexed image. + + newimage = NO + if (acmode == NEW_IMAGE || acmode == NEW_COPY) + if (gc_arg > 0 || (gr_arg <= 0 && gc_arg <= 0)) + newimage = YES + STF_NEWIMAGE(stf) = newimage + + # Generate full header file name. + if (extn[1] == EOS) { + call stf_gethdrextn (im, o_im, acmode, Memc[stf_extn], MAX_LENEXTN) + call iki_mkfname (root, Memc[stf_extn], Memc[fname], SZ_PATHNAME) + call strcpy (Memc[stf_extn], extn, MAX_LENEXTN) + } else + call iki_mkfname (root, extn, Memc[fname], SZ_PATHNAME) + + call strcpy (Memc[fname], IM_HDRFILE(im), SZ_IMHDRFILE) + + # Generate full pixel file name. + call stf_mkpixfname (root, extn, Memc[fname], SZ_PATHNAME) + call strcpy (Memc[fname], IM_PIXFILE(im), SZ_IMPIXFILE) + + # Create and open the image header file if create a new physical + # image. If opening an existing image we do not open the header file + # here since the header may already be in the STF header cache. + # Since STF header files have a weird file type on some systems (VMS) + # we must create a new header file with FMKCOPY rather than OPEN. + + if (STF_NEWIMAGE(stf) == YES && !fnullfile (IM_HDRFILE(im))) { + if (access (IM_HDRFILE(im), 0,0) == YES) { + subimage = (gr_arg > 0 && gr_arg <= gc_arg) + if (subimage || envgetb ("imclobber")) { + iferr (call delete (IM_PIXFILE(im))) + goto err_ + iferr (call delete (IM_HDRFILE(im))) + goto err_ + } else { + call mfree (stf, TY_STRUCT) + call syserrs (SYS_IKICLOB, IM_HDRFILE(im)) + } + } + iferr (call fmkcopy (HDR_TEMPLATE, IM_HDRFILE(im))) + goto err_ + iferr (IM_HFD(im) = open (IM_HDRFILE(im), READ_WRITE, TEXT_FILE)) + goto err_ + } + + # If opening an existing image, read the image header into the STF + # image descriptor. + + switch (acmode) { + case NEW_IMAGE: + # For group formatted images, open NEW_IMAGE can mean either + # creating a new group format image, or opening a new group + # within an existing group format image. The latter case is + # indicated by a group index greater than 1. If we are creating + # a new group format image, wait until the user has set up the + # dimension parameters before doing anything further (in stfopix). + + if (STF_NEWIMAGE(stf) == NO) + iferr (call stf_rdheader (im, group, acmode)) + goto err_ + + case NEW_COPY: + # Make sure the FITS encoded user area we inherited is blocked. + + ### For now, always reblock the old header as the blocked flag + ### does not seem to be reliable and a header with variable length + ### lines can cause the header update to fail. This should be + ### fixed as a reblock of the full header is expensive. + + ### if (IM_UABLOCKED(o_im) != YES) + call stf_reblock (im) + + if (STF_NEWIMAGE(stf) == NO) { + # Open new group within existing GF image. The FITS header and + # GPB structure of the image being opened must be used, but the + # default data values for the GPB parameters are inherited from + # the image being copied. + + # Filter the copied user area to retain only the GPB cards. + # Opening the user area on two string file descriptors is a + # bit tricky, but will work since fixed size cards are copied, + # and the EOS isn't written until close time. + + if (IM_KDES(o_im) != NULL && IM_KERNEL(o_im) == IM_KERNEL(im)) { + hdr = stropen (Memc[ua], ARB, READ_ONLY) + gpb = stropen (Memc[ua], ARB, NEW_FILE) + call stf_copyfits (IM_KDES(o_im), hdr, gpb, NULL) + call close (gpb) + call close (hdr) + } + + # Read in the FITS header of the new image after the inherited + # GPB data cards, and set up the STF descriptor for the new GPB + # as defined in the new FITS header. + + iferr (call stf_rdheader (im, group, acmode)) + goto err_ + + # Initialize the WCS description if this is not done by the + # inherited user header. + + call stf_initwcs (im) + + } else { + # Completely new copy of an existing image, which may or may + # not be an STF format image. IMIO has already copied the + # size parameters of the old image as well as the cards in the + # user area of the old image (but without leaving space for + # the GPB cards if not an STF image). Copy old STF descriptor + # if the old image is also an STF format image, to inherit + # GPB structure. Wait until opix time to init the rest of the + # descriptor. + + if (IM_KDES(o_im) != NULL && IM_KERNEL(o_im) == IM_KERNEL(im)) { + o_stf = IM_KDES(o_im) + o_stflen = LEN_STFBASE + STF_PCOUNT(o_stf) * LEN_PDES + call amovi (Memi[o_stf], Memi[stf], o_stflen) + STF_ACMODE(stf) = acmode + STF_GROUP(stf) = group + STF_GCOUNT(stf) = gcount + STF_NEWIMAGE(stf) = newimage + STF_PFD(stf) = NULL + if (gcount > 1) + STF_GROUPS(stf) = YES + } else + STF_GROUPS(stf) = YES + + # Inherit datatype of input template image if specified, + # otherwise default datatype to real. + + if (IM_PIXTYPE(o_im) != NULL) + IM_PIXTYPE(im) = IM_PIXTYPE(o_im) + else + IM_PIXTYPE(im) = TY_REAL + } + + default: + # Open an existing group within an existing image. + iferr (call stf_rdheader (im, group, acmode)) + goto err_ + } + + # Set group number and count for the external world if this is a group + # format image. + + if (STF_GROUPS(stf) == YES) { + IM_CLINDEX(im) = STF_GROUP(stf) + IM_CLSIZE(im) = STF_GCOUNT(stf) + } + + # Free any unneeded space in the STF descriptor. + if (STF_PCOUNT(stf) > 0) + call realloc (stf, + LEN_STFBASE + STF_PCOUNT(stf)*LEN_PDES, TY_STRUCT) + IM_KDES(im) = stf + status = OK + + call sfree (sp) + return +err_ + status = ERR + call mfree (stf, TY_STRUCT) + call sfree (sp) +end diff --git a/sys/imio/iki/stf/stfopix.x b/sys/imio/iki/stf/stfopix.x new file mode 100644 index 00000000..da353119 --- /dev/null +++ b/sys/imio/iki/stf/stfopix.x @@ -0,0 +1,202 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include <imio.h> +include <fset.h> +include <mach.h> +include "stf.h" + +define NBITS_CHAR (SZB_CHAR * NBITS_BYTE) + +# STF_OPIX -- Open (or create) the pixel storage file. If the image header file +# is `image.hhh' the associated pixel storage file will be `image.hhd' in the +# same directory as the header file. STF_PFD is set if the pixel file is +# physically open. IM_PFD is not set until we have been called by IMIO, since +# we must be called to once set up all the descriptors, even if the pixel file +# was already opened to read the GPB. +# +# dlb, 18-may-88: added code to zero out gpb's in multi-group image for groups +# other than current; prevents strange numbers and when later programs try to +# read the gpb of an otherwise uninitialized group of the image. +# dlb, 29-dec-1988: added code to get default set of GPB parameters and +# correctly initialize STF-kernel descriptor. + +procedure stf_opix (im, status) + +pointer im # image descriptor +int status # return status + +int compress, blklen +bool copy_of_stf_image +int pfd, sz_gpb, group, i +pointer stf, o_stf, o_im, ua, gpb +long sz_pixfile, pixoff, totpix, offset + +int open() +errchk open, fseti, falloc, seek, syserrs, imioff, calloc +errchk write + +include <szpixtype.inc> + +begin + status = OK + if (IM_PFD(im) != NULL) + return + + o_im = IM_OHDR(im) + stf = IM_KDES(im) + ua = IM_USERAREA(im) + + pfd = STF_PFD(stf) + compress = YES + blklen = 1 + pixoff = 1 + + switch (IM_ACMODE(im)) { + case READ_ONLY, READ_WRITE, WRITE_ONLY, APPEND: + if (pfd == NULL) + pfd = open (IM_PIXFILE(im), IM_ACMODE(im), BINARY_FILE) + + case NEW_COPY, NEW_FILE: + # Initialize the IMIO and STF descriptors and allocate the pixel + # file. + + if (STF_NEWIMAGE(stf) == YES) { + # Normalize IMIO header parameters for new image. + call imioff (im, pixoff, compress, blklen) + + # Set up the required GPB parameters for the new image. + # Note - this call can change the STF pointer. + + call stf_newimage (im) + stf = IM_KDES(im) + + # Save the size of the old GPB user area header if we are + # making a new copy of an old STF format image. + + copy_of_stf_image = false + if (IM_ACMODE(im) == NEW_COPY && o_im != NULL) + if (IM_KERNEL(o_im) == IM_KERNEL(im)) + copy_of_stf_image = true + + if (copy_of_stf_image) { + o_stf = IM_KDES(o_im) + STF_PCOUNT(stf) = STF_PCOUNT(o_stf) + STF_PSIZE(stf) = STF_PSIZE(o_stf) + } + +# Since the stf_mergegpb code below has been deactivated, +# there is no need to do the complex and expensive spool/copy +# operation below. (dct 1/4/90) +# ------------------------------- +# # We have to have space for the GPB data cards at the beginning +# # of the user area, so spool any existing user cards in a +# # buffer and truncate the user area at the end of the GPB. +# +# ua_fd = stropen (Memc[ua+sz_gpbhdr], ARB, READ_ONLY) +# spool = open ("opix_spool", READ_WRITE, SPOOL_FILE) +# call fcopyo (ua_fd, spool) +# call close (ua_fd) +# Memc[ua+sz_gpbhdr] = EOS +# +# # Merge any extra GPB parameters from the old image into the +# # GPB structure of the new image. The GPB data cards for +# # these parameters should already be in the user area. +# # Order the group parameters to match the ordering in the +# # old image. NOTE: since the STF now copies all relevant +# # GPB parameters from an old image into the new or +# # generates a default standard set (in stf_newimage), +# # the following is no longer necessary. Note that if we +# # eventually may add parameters to the GPB, these routines +# # will again be useful! +# +# #if (copy_of_stf_image) { +# # call stf_mergegpb (im, o_im) +# # call stf_ordergpb (o_stf, stf) +# #} +# +# # Now append the spooled user header cards to the new user +# # area following the GPB data cards, deleting any user cards +# # which redefine GPB cards in the process. +# +# call seek (spool, BOFL) +# ua_size = (IM_LENHDRMEM(im) - LEN_IMHDR) * SZ_STRUCT +# ua_fd = stropen (Memc[ua], ua_size, APPEND) +# call stf_copyfits (stf, spool, NULL, ua_fd) +# call close (ua_fd) +# call close (spool) +# +# # Compute the length of the new header +# IM_HDRLEN(im) = LEN_IMHDR + +# (strlen(Memc[ua]) + SZ_STRUCT-1) / SZ_STRUCT + + # Open the new pixel storage file (preallocate space if + # enabled on local system). Save the physical pathname of + # the pixfile in the image header, in case "imdir$" changes. + + sz_pixfile = STF_SZGROUP(stf) * STF_GCOUNT(stf) + call falloc (IM_PIXFILE(im), sz_pixfile) + + # Zero out all remaining groups of the image + # Open pixel file if not already open + + if (STF_PFD(stf) == NULL) + pfd = open (IM_PIXFILE(im), READ_WRITE, BINARY_FILE) + + # Allocate a zeroed block of memory whose length is the same + # as that of the group parameter block + + sz_gpb = STF_PSIZE(stf) / NBITS_BYTE / SZB_CHAR + call calloc (gpb, sz_gpb, TY_CHAR) + + # Zero out every group except the current one. + do group = 1, STF_GCOUNT(stf) { + if (group != STF_GROUP(stf)) { + offset = (group * STF_SZGROUP(stf) + 1) - sz_gpb + call seek (pfd, offset) + call write (pfd, Memc[gpb], sz_gpb) + } + } + + # Free the block of memory. + call mfree (gpb, TY_CHAR) + + } else { + # If we are writing to a group of an existing multigroup image, + # verify that the important image parameters have not been + # changed. + + if (STF_NAXIS(stf) != IM_NDIM(im)) + call syserrs (SYS_IMGSZNEQ, IM_NAME(im)) + do i = 1, IM_NDIM(im) + if (STF_LENAXIS(stf,i) != IM_LEN(im,i)) + call syserrs (SYS_IMGSZNEQ, IM_NAME(im)) + + # Added 5/15/87--dlb to get correct size of each data portion + # of a group if image opened NEW_COPY and input file was a + # template of a different dimensionality used to get GPB. + # Compute the size of each group in the pixel file, in chars. + + totpix = IM_LEN(im,1) + do i = 2, IM_NDIM(im) + totpix = totpix * IM_LEN(im,i) + + STF_SZGROUP(stf) = totpix * pix_size[IM_PIXTYPE(im)] + + STF_PSIZE(stf) / (SZB_CHAR * NBITS_BYTE) + } + + if (pfd == NULL) + pfd = open (IM_PIXFILE(im), READ_WRITE, BINARY_FILE) + + # Tell IMIO where the pixels are. + pixoff = (STF_GROUP(stf) - 1) * STF_SZGROUP(stf) + 1 + call imioff (im, pixoff, compress, blklen) + + default: + call imerr (IM_NAME(im), SYS_IMACMODE) + } + + STF_PFD(stf) = pfd + IM_PFD(im) = pfd +end diff --git a/sys/imio/iki/stf/stfordgpb.x b/sys/imio/iki/stf/stfordgpb.x new file mode 100644 index 00000000..7099e106 --- /dev/null +++ b/sys/imio/iki/stf/stfordgpb.x @@ -0,0 +1,64 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> +include "stf.h" + +# STF_ORDERGPB -- Order the GPB, putting the group parameters in the +# new image in the same order as in the old image. +# NOTE: no longer called by stf_opix; save this code for future use! +# <dlb--11/4/87> + +procedure stf_ordergpb (o_stf, n_stf) + +pointer o_stf # STF descriptor of old image +pointer n_stf # STF descriptor of new image + +pointer sp, temp_pdes, pp, o_plist, n_plist +int o_pcount, n_pcount, otop, ntop, op, np, offset, sz_param, pn +bool streq() + +begin + o_pcount = STF_PCOUNT(o_stf) + n_pcount = STF_PCOUNT(n_stf) + if (o_pcount <= 0) + return + + call smark (sp) + call salloc (temp_pdes, LEN_PDES, TY_STRUCT) + + o_plist = STF_PDES(o_stf,1) + n_plist = STF_PDES(n_stf,1) + otop = (o_pcount * LEN_PDES) + ntop = (n_pcount * LEN_PDES) + + # Search the new parameter list for a parameter with the same name + # as a parameter in the old parameter list. When a match is found, + # move the new parameter into the same position as it is in the + # old parameter list. + + for (op=0; op < otop; op=op+LEN_PDES) + for (np=op; np < ntop; np=np+LEN_PDES) + if (streq (P_PTYPE(o_plist+op), P_PTYPE(n_plist+np))) { + if (op != np) { + # Swap parameters between old and new positions + call amovi (Memi[n_plist+op], Memi[temp_pdes], + LEN_PDES) + call amovi (Memi[n_plist+np], Memi[n_plist+op], + LEN_PDES) + call amovi (Memi[temp_pdes], Memi[n_plist+np], + LEN_PDES) + } + break + } + + # Update the field offsets. + offset = 0 + for (pn=1; pn <= n_pcount; pn=pn+1) { + pp = STF_PDES(n_stf,pn) + P_OFFSET(pp) = offset + sz_param = P_PSIZE(pp) / NBITS_BYTE / SZB_CHAR + offset = offset + sz_param + } + + call sfree (sp) +end diff --git a/sys/imio/iki/stf/stfrdhdr.x b/sys/imio/iki/stf/stfrdhdr.x new file mode 100644 index 00000000..2c11fec9 --- /dev/null +++ b/sys/imio/iki/stf/stfrdhdr.x @@ -0,0 +1,186 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <finfo.h> +include <imhdr.h> +include <imio.h> +include <mach.h> +include "stf.h" + +# STF_RDHEADER -- Read the STF format image header for a single group into the +# IMIO descriptor. The standard fields are processed into the fields of the +# descriptor. The GPB binary parameters are encoded as FITS cards and placed +# in the IMIO user area, followed by all extra cards in the FITS format STF +# group header. Note that no distinction is made between the common FITS +# keywords and the GPB group parameters at the IMIO level and above. + +procedure stf_rdheader (im, group, acmode) + +pointer im # image descriptor +int group # group to be accessed +int acmode # access mode + +long pixoff +long fi[LEN_FINFO] +real datamin, datamax +pointer sp, stf, lbuf, root, extn, op +int compress, devblksz, ival, ch, i , junk +int fits, fitslen, sz_userarea, sz_gpbhdr, len_hdrmem +long totpix, mtime, ctime + +real imgetr() +int fnroot(), strlen(), finfo(), imaccf() +errchk stf_rfitshdr, stf_rgpb, open, realloc, imaddb, imaddi, imgetr + +include <szpixtype.inc> + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + call salloc (root, SZ_FNAME, TY_CHAR) + call salloc (extn, SZ_FNAME, TY_CHAR) + + stf = IM_KDES(im) + + # Read the FITS header, setting the values of all reserved fields + # in the STF descriptor and saving all the user FITS cards in the + # save buffer "fits". + + call stf_rfitshdr (im, fits, fitslen) + + # Process the reserved keywords (set in the STF descriptor) into the + # corresponding fields of the IMIO descriptor. + + # Set group keywords if STF_GROUPS is NO (BPS 12.06.91). + if (STF_GROUPS(stf) == NO) { + STF_GCOUNT(stf) = 1 + STF_PCOUNT(stf) = 0 + STF_PSIZE(stf) = 0 + } + + if (acmode != NEW_COPY) { + IM_NDIM(im) = STF_NAXIS(stf) # IM_NDIM + do ival = 1, IM_MAXDIM # IM_LEN + IM_LEN(im,ival) = STF_LENAXIS(stf,ival) + } + + ch = STF_DATATYPE(stf) # IM_PIXTYPE + switch (STF_BITPIX(stf)) { + case 16: + if (ch == 'U') + ival = TY_USHORT + else + ival = TY_SHORT + case 32: + if (ch == 'R') + ival = TY_REAL + else + ival = TY_LONG + case 64: + if (ch == 'R') + ival = TY_DOUBLE + else + ival = TY_COMPLEX + default: + ival = ERR + } + IM_PIXTYPE(im) = ival + + call iki_parse (IM_HDRFILE(im), Memc[root], Memc[extn]) + call stf_mkpixfname (Memc[root], Memc[extn], IM_PIXFILE(im), + SZ_IMPIXFILE) + + if (finfo (IM_PIXFILE(im), fi) != ERR) { + mtime = FI_MTIME(fi) + ctime = FI_CTIME(fi) + } + + IM_NBPIX(im) = 0 # no. bad pixels + IM_CTIME(im) = ctime # creation time + IM_MTIME(im) = mtime # modify time + IM_LIMTIME(im) = mtime - 1 # time max/min last updated + IM_UABLOCKED(im) = YES # ua cards blocked to 80 chars + + IM_HISTORY(im) = EOS + junk = fnroot (IM_HDRFILE(im), Memc[lbuf], SZ_LINE) + call strupr (Memc[lbuf]) + call sprintf (IM_TITLE(im), SZ_IMTITLE, "%s[%d/%d]") + call pargstr (Memc[lbuf]) + call pargi (STF_GROUP(stf)) + call pargi (STF_GCOUNT(stf)) + + # Compute the size of each group in the pixel file, in chars. + totpix = IM_LEN(im,1) + do i = 2, IM_NDIM(im) + totpix = totpix * IM_LEN(im,i) + + STF_SZGROUP(stf) = totpix * pix_size[IM_PIXTYPE(im)] + + STF_PSIZE(stf) / (SZB_CHAR * NBITS_BYTE) + + # Write GPB related cards to the beginning of the IMIO user area. + call imaddb (im, "GROUPS", STF_GROUPS(stf) == YES) + call imaddi (im, "GCOUNT", STF_GCOUNT(stf)) + call imaddi (im, "PCOUNT", STF_PCOUNT(stf)) + call imaddi (im, "PSIZE", STF_PSIZE(stf)) + + # Extract the group parameter block from the pixfile, encoding the + # group parameters as FITS cards and appending to the cards above. + # Get the values of DATAMIN and DATAMAX from the GPB so that we can + # update the IMIO min/max fields. + + call stf_rgpb (im, group, acmode, datamin, datamax) + + # Reallocate the image descriptor to allow space for the spooled user + # FITS cards plus a little extra for new parameters. + + sz_gpbhdr = strlen (Memc[IM_USERAREA(im)]) + sz_userarea = sz_gpbhdr + fitslen + SZ_EXTRASPACE + + IM_HDRLEN(im) = LEN_IMHDR + + (sz_userarea - SZ_EXTRASPACE + SZ_MII_INT-1) / SZ_MII_INT + len_hdrmem = LEN_IMHDR + + (sz_userarea+1 + SZ_MII_INT-1) / SZ_MII_INT + + if (IM_LENHDRMEM(im) < len_hdrmem) { + IM_LENHDRMEM(im) = len_hdrmem + call realloc (im, IM_LENHDRMEM(im) + LEN_IMDES, TY_STRUCT) + } + + # Append the saved FITS cards from the STF header to the user area. + # Any cards which redefine GPB cards were already deleted when the + # fits save buffer was created (we don't want the GPB cards since + # we already output a FITS card for each GPB parameter above). + + op = IM_USERAREA(im) + sz_gpbhdr + call amovc (Memc[fits], Memc[op], fitslen+1) + + # Set the IMIO min/max fields. If the GPB datamin >= datamax the + # values are invalidated by setting IM_LIMTIME to before the image + # modification time. Although datamin/datamax were returned by + # stg_rgpb above, we refetch the values here to pick up the values + # from the spooled main header in case there were no entries for + # these keywords in the GPB (if there are values in the GPB they + # will override those in the main header). + + if (imaccf (im, "DATAMIN") == YES) + datamin = imgetr (im, "DATAMIN") + if (imaccf (im, "DATAMAX") == YES) + datamax = imgetr (im, "DATAMAX") + + IM_MIN(im) = datamin + IM_MAX(im) = datamax + if (datamin < datamax) + IM_LIMTIME(im) = IM_MTIME(im) + 1 + else + IM_LIMTIME(im) = IM_MTIME(im) - 1 + + # Call up IMIO set set up the remaining image header fields used to + # define the physical offsets of the pixels in the pixfile. + + compress = YES # do not align image lines on blocks + devblksz = 1 # disable all alignment + + pixoff = (group - 1) * STF_SZGROUP(stf) + 1 + call imioff (im, pixoff, compress, devblksz) + + call sfree (sp) +end diff --git a/sys/imio/iki/stf/stfreblk.x b/sys/imio/iki/stf/stfreblk.x new file mode 100644 index 00000000..9519bd08 --- /dev/null +++ b/sys/imio/iki/stf/stfreblk.x @@ -0,0 +1,65 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> +include "stf.h" + +# STF_REBLOCK -- If the user area is not blocked to fixed length records, e.g., +# as is possible in a new copy image, reblock it fixed length. + +procedure stf_reblock (im) + +pointer im # image descriptor + +pointer sp, lbuf, op, ua +int fd, spool, nlines, nchars, sz_userarea, len_hdrmem +errchk stropen, open, getline, putline, realloc, seek, fcopyo +int open(), stropen(), getline() + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + ua = IM_USERAREA(im) + fd = stropen (Memc[ua], ARB, READ_ONLY) + spool = open ("rb_spool", READ_WRITE, SPOOL_FILE) + + # Reblock into a spool file, counting the lines. + for (nlines=0; ; nlines=nlines+1) { + nchars = getline (fd, Memc[lbuf]) + if (nchars <= 0) + break + + for (op=nchars; op <= FITS_RECLEN; op=op+1) + Memc[lbuf+op-1] = ' ' + Memc[lbuf+FITS_RECLEN] = '\n' + Memc[lbuf+FITS_RECLEN+1] = EOS + + call putline (spool, Memc[lbuf]) + } + + call close (fd) + + # Reallocate header the right size. + sz_userarea = nlines * (FITS_RECLEN+1) + SZ_EXTRASPACE + + IM_HDRLEN(im) = LEN_IMHDR + + (sz_userarea - SZ_EXTRASPACE + SZ_MII_INT-1) / SZ_MII_INT + len_hdrmem = LEN_IMHDR + + (sz_userarea+1 + SZ_MII_INT-1) / SZ_MII_INT + + if (IM_LENHDRMEM(im) < len_hdrmem) { + IM_LENHDRMEM(im) = len_hdrmem + call realloc (im, IM_LENHDRMEM(im) + LEN_IMDES, TY_STRUCT) + } + + # Move spooled data back to user area. + ua = IM_USERAREA(im) + fd = stropen (Memc[ua], sz_userarea, NEW_FILE) + call seek (spool, BOFL) + call fcopyo (spool, fd) + + call close (fd) + call close (spool) + call sfree (sp) +end diff --git a/sys/imio/iki/stf/stfrename.x b/sys/imio/iki/stf/stfrename.x new file mode 100644 index 00000000..0d3c43fd --- /dev/null +++ b/sys/imio/iki/stf/stfrename.x @@ -0,0 +1,49 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include "stf.h" + +# STF_RENAME -- Rename an image. A special operator is required since the image +# is stored as two files. +# +# [NOTE] - Name changed to `rname' rather than `rename' to avoid a name +# collision with the SYMTAB procedure `stfree' (first such collision!). + +procedure stf_rname (kernel, oroot, oextn, nroot, nextn, status) + +int kernel #I IKI kernel +char oroot[ARB] # old image root name +char oextn[ARB] # old image extn +char nroot[ARB] # new image root name +char nextn[ARB] # old image extn +int status + +pointer sp +pointer ohdr_fname, opix_fname, nhdr_fname, npix_fname +bool streq() + +begin + call smark (sp) + call salloc (ohdr_fname, SZ_PATHNAME, TY_CHAR) + call salloc (opix_fname, SZ_PATHNAME, TY_CHAR) + call salloc (nhdr_fname, SZ_PATHNAME, TY_CHAR) + call salloc (npix_fname, SZ_PATHNAME, TY_CHAR) + + # Generate filenames. + call iki_mkfname (oroot, oextn, Memc[ohdr_fname], SZ_PATHNAME) + call iki_mkfname (nroot, nextn, Memc[nhdr_fname], SZ_PATHNAME) + + if (!streq (Memc[ohdr_fname], Memc[nhdr_fname])) { + call stf_mkpixfname (oroot, oextn, Memc[opix_fname], SZ_PATHNAME) + call stf_mkpixfname (nroot, nextn, Memc[npix_fname], SZ_PATHNAME) + + # If the header cannot be renamed, don't leave the pixfile alone. + iferr (call rename (Memc[ohdr_fname], Memc[nhdr_fname])) + call erract (EA_WARN) + else iferr (call rename (Memc[opix_fname], Memc[npix_fname])) + call erract (EA_WARN) + } + + call sfree (sp) + status = OK +end diff --git a/sys/imio/iki/stf/stfrfits.x b/sys/imio/iki/stf/stfrfits.x new file mode 100644 index 00000000..8ec9e9b0 --- /dev/null +++ b/sys/imio/iki/stf/stfrfits.x @@ -0,0 +1,266 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <ctype.h> +include <imhdr.h> +include <imio.h> +include <finfo.h> +include <fset.h> +include "stf.h" + +# STF_RFITSHDR -- Read a STF FITS image header, processing all reserved GPB +# definition keywords into the STF descriptor in the image descriptor, and +# saving the remaining cards (excluding cards which GPB keyword names) in +# in a save buffer. +# +# This routine implements a simple cache of FITS headers. If a given header +# is already in the cache and the cached entry is up to date, the cached +# spool file containing the user FITS cards and the saved STF descriptor are +# returned immediately without need to access the header file on disk. +# Otherwise, the new header is read into the oldest cache slot and the cached +# entry returned in the usual fashion. Any modifications to the header file +# which affect the file modify date will invalidate the cached entry. Note +# that multiple processes may cache the same header, so it is not permitted +# to modify the cached entry once the header file has been read. +# +# The following reserved keywords are recognized: +# +# SIMPLE BITPIX DATATYPE NAXIS* GROUPS GCOUNT PCOUNT PSIZE +# PTYPE* PDTYPE* PSIZE* +# +# All unrecognized cards, including HISTORY and COMMENT cards, blank lines, +# and any other garbage in the header, are preserved in the user area of the +# IMIO descriptor (i.e., in the spoolfile). Certain of the standard reserved +# cards (GROUPS, GCOUNT, etc.) are saved in the IMIO user area for the sake +# of the user, although the real values of these parameters are maintained only +# in the STF descriptor. + +procedure stf_rfitshdr (im, fits, fitslen) + +pointer im #I image descriptor +pointer fits #O pointer to saved FITS cards +int fitslen #O length of FITS save area + +long fi[LEN_FINFO] +pointer sp, pp, stf, o_stf, lbuf, op, hdrfile +int in, index, nchars, spool, slot, user, i + +bool streq() +long clktime(), fstatl() +int envgeti(), stf_ctype(), finfo(), getline(), open(), stropen() +errchk getline, putline, syserrs, open, seek, calloc, realloc +errchk fpathname, malloc, stf_copyfits + +bool initialized # CACHE definitions... +bool reload # reload cache +int rf_refcount # reference count +int rf_cachesize # number of cache slots +pointer rf_stf[MAX_CACHE] # STF descriptor +int rf_lru[MAX_CACHE] # lowest value is oldest slot +long rf_time[MAX_CACHE] # time when entry was cached +long rf_mtime[MAX_CACHE] # modify time of file in cache +int rf_fits[MAX_CACHE] # FITS data +int rf_fitslen[MAX_CACHE] # size of data area +char rf_fname[SZ_PATHNAME,MAX_CACHE] # header file pathname +data initialized /false/ + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + call salloc (hdrfile, SZ_PATHNAME, TY_CHAR) + + # Initialize the header file cache on the first call. + if (!initialized) { + rf_refcount = 0 + do i = 1, MAX_CACHE + rf_stf[i] = 0 + + iferr (rf_cachesize = envgeti (ENV_STFCACHE)) + rf_cachesize = DEF_CACHE + if (rf_cachesize > MAX_CACHE) { + call eprintf ("A maximum of %d STF headers may be cached\n") + call pargi (MAX_CACHE) + rf_cachesize = MAX_CACHE + } else if (rf_cachesize <= 0) + rf_cachesize = 0 + + initialized = true + } + + rf_refcount = rf_refcount + 1 + o_stf = IM_KDES(im) + reload = false + slot = 1 + + # Get file system info on the desired header file. + call fpathname (IM_HDRFILE(im), Memc[hdrfile], SZ_PATHNAME) + if (finfo (Memc[hdrfile], fi) == ERR) + call syserrs (SYS_FOPEN, IM_HDRFILE(im)) + + repeat { + # Search the header file cache for the named image. + do i = 1, max(1,rf_cachesize) { + if (rf_stf[i] == NULL) { + slot = i + next + } + + if (streq (Memc[hdrfile], rf_fname[1,i])) { + # File is in cache; is cached entry still valid? + if (FI_MTIME(fi) != rf_mtime[i]) { + # File modify date has changed, reuse slot. + slot = i + break + + } else if (!reload && clktime(rf_time[i]) < 2) { + # The file modify date has not changed, but the cache + # was loaded within the last clock "tick" (second), + # so we cannot be sure that the file was not modified. + # The cache must be reloaded, but set a flag so that + # rf_time is not changed, so that when the cache entry + # ages sufficiently it will be considered valid. + + reload = true + slot = i + break + + } else { + # Return the cached header. + rf_lru[i] = rf_refcount + call amovi (STF_CACHE(rf_stf[i]), STF_CACHE(o_stf), + STF_CACHELEN(rf_stf[i])) + fits = rf_fits[i] + fitslen = rf_fitslen[i] + + # Invalidate entry if cache is disabled. + if (rf_cachesize <= 0) + rf_time[i] = 0 + + call sfree (sp) + return # IN CACHE + } + + } else { + # Keep track of least recently used slot. + if (rf_lru[i] < rf_lru[slot]) + slot = i + } + } + + # Either the image header is not in the cache, or the cached + # entry is invalid. Prepare the given cache slot and read the + # header into it. + + # Free old save buffer and descriptor. + if (rf_stf[slot] != NULL) { + call mfree (rf_stf[slot], TY_STRUCT) + call mfree (rf_fits[slot], TY_CHAR) + } + + # Open the header file. + if (IM_HFD(im) == NULL) + in = open (Memc[hdrfile], READ_ONLY, TEXT_FILE) + else { + in = IM_HFD(im) + call seek (in, BOFL) + } + + # Allocate a spool file for the FITS data. + call sprintf (rf_fname[1,slot], SZ_PATHNAME, "STFHC#%d") + call pargi (slot) + spool = open (rf_fname[1,slot], READ_WRITE, SPOOL_FILE) + call fseti (spool, F_BUFSIZE, FI_SIZE(fi)) + + # Allocate cache version of STF descriptor. + call calloc (stf, LEN_STFDES, TY_STRUCT) + + # Initialize the cache entry. + call strcpy (Memc[hdrfile], rf_fname[1,slot], SZ_PATHNAME) + rf_stf[slot] = stf + rf_lru[slot] = rf_refcount + rf_mtime[slot] = FI_MTIME(fi) + if (!reload) + rf_time[slot] = clktime (0) + reload = true + + # Read successive lines of the FITS header. Process reserved + # keywords into the STF descriptor and spool the remaining cards + # to the fits spool file. + + repeat { + # Get the next input line. + nchars = getline (in, Memc[lbuf]) + if (nchars == EOF) + break + + # Block it out to 80 chars (plus newline) if it is not already. + if (nchars != FITS_RECLEN + 1) { + for (op=nchars; op <= FITS_RECLEN; op=op+1) + Memc[lbuf+op-1] = ' ' + Memc[lbuf+FITS_RECLEN] = '\n' + Memc[lbuf+FITS_RECLEN+1] = EOS + } + + # Process the header card. + switch (stf_ctype (Memc[lbuf], index)) { + case KW_BITPIX: + call stf_geti (Memc[lbuf], STF_BITPIX(stf)) + case KW_DATATYPE: + call stf_gets (Memc[lbuf], STF_DATATYPE(stf), SZ_DATATYPE) + case KW_END: + break + case KW_GCOUNT: + call stf_geti (Memc[lbuf], STF_GCOUNT(stf)) + case KW_GROUPS: + call stf_getb (Memc[lbuf], STF_GROUPS(stf)) + case KW_NAXIS: + call stf_geti (Memc[lbuf], STF_NAXIS(stf)) + case KW_NAXISN: + call stf_geti (Memc[lbuf], STF_LENAXIS(stf,index)) + case KW_PCOUNT: + call stf_geti (Memc[lbuf], STF_PCOUNT(stf)) + case KW_PDTYPE: + pp = STF_PDES(stf,min(index,MAX_PCOUNT)) + call stf_gets (Memc[lbuf], P_PDTYPE(pp), SZ_PDTYPE) + case KW_PSIZE: + call stf_geti (Memc[lbuf], STF_PSIZE(stf)) + case KW_PSIZEN: + pp = STF_PDES(stf,min(index,MAX_PCOUNT)) + call stf_geti (Memc[lbuf], P_PSIZE(pp)) + case KW_PTYPE: + pp = STF_PDES(stf,min(index,MAX_PCOUNT)) + call stf_gets (Memc[lbuf], P_PTYPE(pp), SZ_PTYPE) + call stf_getcmt (Memc[lbuf], P_COMMENT(pp), SZ_COMMENT) + case KW_SIMPLE: + ; + default: + call putline (spool, Memc[lbuf]) + } + } + + # Close the header file if opened locally. + if (IM_HFD(im) == NULL) + call close (in) + + # Free any unneeded space in the STF descriptor. + if (STF_PCOUNT(stf) > 0) { + call realloc (stf, + LEN_STFBASE + STF_PCOUNT(stf)*LEN_PDES, TY_STRUCT) + rf_stf[slot] = stf + } + + # Filter the spooled FITS cards to delete any cards which redefine + # GPB keywords. Store the filtered FITS data in the cache. + + call seek (spool, BOFL) + nchars = fstatl (spool, F_FILESIZE) + call malloc (fits, nchars, TY_CHAR) + user = stropen (Memc[fits], nchars, NEW_FILE) + call stf_copyfits (stf, spool, NULL, user) + + rf_fits[slot] = fits + rf_fitslen[slot] = fstatl (user, F_FILESIZE) + call close (user) + call close (spool) + } +end diff --git a/sys/imio/iki/stf/stfrgpb.x b/sys/imio/iki/stf/stfrgpb.x new file mode 100644 index 00000000..15c4da0a --- /dev/null +++ b/sys/imio/iki/stf/stfrgpb.x @@ -0,0 +1,179 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> +include <mach.h> +include "stf.h" + +# STF_RGPB -- Read the group data block into the first few cards of the user +# area of the IMIO image header. The GPB is stored as a binary data structure +# in the STF pixfile. The values of the standard GPB parameters DATAMIN and +# DATAMAX are returned as output arguments. +# +# DLB--11/03/87: Made changes to allow i*2 and i*4 integer parameters in GPB. +# DLB--11/11/87: Changed calculation of character string length in GPB to +# avoid integer truncation error by using P_PSIZE directly. + +procedure stf_rgpb (im, group, acmode, datamin, datamax) + +pointer im # IMIO image descriptor +int group # group to be accessed +int acmode # image access mode +real datamin, datamax # min,max pixel values from GPB + +real rval +double dval +short sval +long lval, offset +bool bval, newgroup +pointer sp, stf, gpb, lbuf, pp +int pfd, pn, sz_param, sz_gpb +errchk imaddb, imadds, imaddl, imaddr, imaddd, imastr +errchk imputd, impstr, open, read +int open(), read(), imaccf() +real imgetr() + +string readerr "cannot read group data block - no such group?" +string badtype "illegal group data parameter datatype" +string nogroup "group index out of range" +define minmax_ 91 + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + stf = IM_KDES(im) + pfd = STF_PFD(stf) + + # Verify that the given group exists. + if (group < 1 || group > STF_GCOUNT(stf)) + call error (1, nogroup) + + # Skip ahead if there is no group parameter block. + if (STF_PSIZE(stf) == 0) + goto minmax_ + + # Open the pixel file if not already open. + if (pfd == NULL) { + iferr { + if (IM_ACMODE(im) == READ_ONLY) + pfd = open (IM_PIXFILE(im), READ_ONLY, BINARY_FILE) + else + pfd = open (IM_PIXFILE(im), READ_WRITE, BINARY_FILE) + STF_PFD(stf) = pfd + } then { + call eprintf ("Warning: Cannot open pixfile to read GPB (%s)\n") + call pargstr (IM_NAME(im)) + pfd = NULL + } + } + + # Allocate a buffer for the GPB. + sz_gpb = STF_PSIZE(stf) / NBITS_BYTE / SZB_CHAR + call salloc (gpb, sz_gpb, TY_CHAR) + + # Read the GPB into a buffer. The GPB is located at the very end of + # the data storage area for the group. If we are opening a new, + # uninitialized group (acmode = new_image or new_copy), do not + # physically read the GPB as it is will be uninitialized data. + + newgroup = (acmode == NEW_IMAGE || acmode == NEW_COPY || pfd == NULL) + if (newgroup) + call aclrc (Memc[gpb], sz_gpb) + else { + offset = (group * STF_SZGROUP(stf) + 1) - sz_gpb + call seek (pfd, offset) + if (read (pfd, Memc[gpb], sz_gpb) != sz_gpb) + call error (1, readerr) + } + + # Extract the binary value of each parameter in the GPB and encode it + # in FITS format in the IMIO user area. + + offset = 0 + for (pn=1; pn <= STF_PCOUNT(stf); pn=pn+1) { + pp = STF_PDES(stf,pn) + + # Fill in the unitialized fields of the GPB parameter descriptor. + P_OFFSET(pp) = offset + sz_param = P_PSIZE(pp) / NBITS_BYTE / SZB_CHAR + + switch (P_PDTYPE(pp)) { + # changed case for int to short and long--dlb 11/3/87 + case 'I': + if (sz_param == SZ_SHORT) + P_SPPTYPE(pp) = TY_SHORT + else + P_SPPTYPE(pp) = TY_LONG + P_LEN(pp) = 1 + case 'R': + if (sz_param == SZ_REAL) + P_SPPTYPE(pp) = TY_REAL + else + P_SPPTYPE(pp) = TY_DOUBLE + P_LEN(pp) = 1 + case 'C': + P_SPPTYPE(pp) = TY_CHAR + # calculate length directly from PSIZE to avoid truncation error + P_LEN(pp) = min (SZ_LINE, P_PSIZE(pp) / NBITS_BYTE) + case 'L': + P_SPPTYPE(pp) = TY_BOOL + P_LEN(pp) = 1 + default: + call error (1, badtype) + } + + # Extract the binary parameter value and add a FITS encoded card + # to the IMIO user area. In the case of a new copy image, the + # GPB values will already be in the image header, do not modify + # the parameter value, but add the parameter if it was not + # inherited from the old image. + + if (acmode != NEW_COPY || imaccf (im, P_PTYPE(pp)) == NO) { + switch (P_SPPTYPE(pp)) { + case TY_BOOL: + if (SZ_INT != SZ_INT32) + call amovc (Memc[gpb+offset], bval, SZ_INT32) + else + call amovc (Memc[gpb+offset], bval, SZ_BOOL) + call imaddb (im, P_PTYPE(pp), bval) + case TY_SHORT: + call amovc (Memc[gpb+offset], sval, SZ_SHORT) + call imadds (im, P_PTYPE(pp), sval) + case TY_LONG: + if (SZ_INT != SZ_INT32) + call amovc (Memc[gpb+offset], lval, SZ_INT32) + else + call amovc (Memc[gpb+offset], lval, SZ_LONG) + call imaddl (im, P_PTYPE(pp), lval) + case TY_REAL: + call amovc (Memc[gpb+offset], rval, SZ_REAL) + call imaddr (im, P_PTYPE(pp), rval) + case TY_DOUBLE: + call amovc (Memc[gpb+offset], dval, SZ_DOUBLE) + call imaddd (im, P_PTYPE(pp), dval) + case TY_CHAR: + call chrupk (Memc[gpb+offset], 1, Memc[lbuf], 1, P_LEN(pp)) + Memc[lbuf+P_LEN(pp)] = EOS + call imastr (im, P_PTYPE(pp), Memc[lbuf]) + default: + call error (1, badtype) + } + } + + offset = offset + sz_param + } + +minmax_ + # Return DATAMIN, DATAMAX. This is done by searching the user area so + # that ordinary keywords may be used to set datamin and datamax if the + # GPB is not used. + + datamin = 0.0; datamax = 0.0 + if (imaccf (im, "DATAMIN") == YES) + datamin = imgetr (im, "DATAMIN") + if (imaccf (im, "DATAMAX") == YES) + datamax = imgetr (im, "DATAMAX") + + call sfree (sp) +end diff --git a/sys/imio/iki/stf/stfupdhdr.x b/sys/imio/iki/stf/stfupdhdr.x new file mode 100644 index 00000000..a4519c24 --- /dev/null +++ b/sys/imio/iki/stf/stfupdhdr.x @@ -0,0 +1,60 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include <imio.h> +include "stf.h" + +# STF_UPDHDR -- Update the STF/GEIS format image header. + +procedure stf_updhdr (im, status) + +pointer im # image descriptor +int status # return status + +pointer stf +int acmode +real datamin, datamax +errchk imerr, imputr, stf_wgpb + +begin + acmode = IM_ACMODE(im) + status = OK + stf = IM_KDES(im) + + if (acmode == READ_ONLY) + call imerr (IM_NAME(im), SYS_IMUPIMHDR) + + # Compute the values of DATAMIN and DATAMAX. + if (IM_LIMTIME(im) == 0 || IM_LIMTIME(im) < IM_MTIME(im)) { + datamin = 0. + datamax = 0. + } else { + datamin = IM_MIN(im) + datamax = IM_MAX(im) + } + + # Update the group parameter block. + call stf_wgpb (im, STF_GROUP(stf), datamin, datamax) + +# # Update the FITS header file, unless we are writing to a new group +# # in an existing group format image, in which case only the GPB is +# # updated. +# +# if (acmode != NEW_IMAGE && acmode != NEW_COPY) +# call stf_wfitshdr (im) +# else if (STF_NEWIMAGE(stf) == YES) +# call stf_wfitshdr (im) + + # The new strategy for FITS header updates is to always update, unless + # we are explicitly updating an existing group of a multigroup image. + # Hence, the FITS header is always updated for an STF image with only + # one group, or when writing the first group of a new STF imagefile. + # The FITS header of an existing STF multigroup image can still be + # updated, but only if the image is not opened to any particular group, + # e.g., as "pix" rather than "pix[n]", N > 0. NEW_[IMAGE|COPY] or + # READ_WRITE access to "pix[n]" will update only the GPB header. + + if (STF_NEWIMAGE(stf)==YES || STF_GCOUNT(stf)<=1 || STF_GRARG(stf)==0) + call stf_wfitshdr (im) +end diff --git a/sys/imio/iki/stf/stfwfits.x b/sys/imio/iki/stf/stfwfits.x new file mode 100644 index 00000000..c444a235 --- /dev/null +++ b/sys/imio/iki/stf/stfwfits.x @@ -0,0 +1,147 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include <imhdr.h> +include <imio.h> +include <fio.h> +include "stf.h" + +# STF_WFITSHDR -- Update the FITS header file. This is done by writing an +# entire new header file and then replacing the old header file with the +# new one. This is necessary since the header file is a text file and text +# files cannot be randomly updated. + +procedure stf_wfitshdr (im) + +pointer im # image descriptor + +pointer sp, fname, lbuf, stf, pp +int in, out, pn, junk, i, width + +bool fnullfile() +int stropen(), open(), protect(), strlen() #ditto-dlb +errchk fmkcopy, open, stropen, fcopyo, fprintf + +begin + if (fnullfile (IM_HDRFILE(im))) + return + + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + stf = IM_KDES(im) + + # Open a new header file with a unique, temporary name. Make a copy + # of the template file rather than of the old header file. Since + # we also block header lines out to 80 chars automatically, this + # means that we can read any old text file but will always generate + # a new header file of the standard type when the header is updated. + + call mktemp (IM_HDRFILE(im), Memc[fname], SZ_FNAME) + call fmkcopy (HDR_TEMPLATE, Memc[fname]) + out = open (Memc[fname], APPEND, TEXT_FILE) + + # Write out the standard, reserved header parameters. + + call fprintf (out, "SIMPLE =%21s /%81t\n") + call pargstr ("F") + call fprintf (out, "BITPIX =%21d /%81t\n") + call pargi (STF_BITPIX(stf)) + + # We want to get the full string length or 8 characters, + # whichever is greater--6/25/87, dlb + + call fprintf (out, "DATATYPE= '%*.*s'%32t/%81t\n") + width = max(8, strlen(STF_DATATYPE(STF))) + call pargi (-width) # force left-justified field + call pargi (width) + call pargstr (STF_DATATYPE(stf)) + + call fprintf (out, "NAXIS =%21d /%81t\n") + call pargi (STF_NAXIS(stf)) + do i = 1, STF_NAXIS(stf) { + call fprintf (out, "NAXIS%d%9t=%21d /%81t\n") + call pargi (i) + call pargi (STF_LENAXIS(stf,i)) + } + + call fprintf (out, "GROUPS =%21s /%81t\n") + if (STF_GROUPS(stf) == YES) + call pargstr ("T") + else + call pargstr ("F") + + # Changed order of the following three cards to conform + # to SOGS expectations--dlb, 7/14/87 + # Only write group keywords if STF_GROUPS is YES (BPS 12.06.91) + + if (STF_GROUPS(stf) == YES) { + call fprintf (out, "GCOUNT =%21d /%81t\n") + call pargi (STF_GCOUNT(stf)) + call fprintf (out, "PCOUNT =%21d /%81t\n") + call pargi (STF_PCOUNT(stf)) + call fprintf (out, "PSIZE =%21d /%81t\n") + call pargi (STF_PSIZE(stf)) + } + + # Add cards defining the fields of the group parameter block. Each + # field requires three cards. + + for (pn=1; pn <= STF_PCOUNT(stf); pn=pn+1) { + pp = STF_PDES(stf,pn) + + # PTYPE MUST be 8 characters or less. + call fprintf (out, "PTYPE%d%9t= '%-8.8s'%32t/%s%81t\n") + call pargi (pn) + call pargstr (P_PTYPE(pp)) + call pargstr (P_COMMENT(pp)) + + # Need width for string--6/26/87, dlb + call fprintf (out, "PDTYPE%d%9t= '%-*.*s'%32t/%81t\n") + call pargi (pn) + width = max (8, strlen(P_PDTYPE(pp))) + call pargi (-width) # force left-justified field + call pargi (width) + call pargstr (P_PDTYPE(pp)) + + call fprintf (out, "PSIZE%d%9t=%21d /%81t\n") + call pargi (pn) + call pargi (P_PSIZE(pp)) + } + + # Add the contents of the IMIO user area, excluding the cards used + # to represent GPB parameters. + + in = stropen (Memc[IM_USERAREA(im)], ARB, READ_ONLY) + call stf_copyfits (stf, in, NULL, out) + call close (in) + + # End of FITS header. + call fprintf (out, "END%81t\n") + call close (out) + + # Replace the original header file with the new one, even if the + # original header is a protected file. Transfer any file protection + # to the new file. + + if (IM_HFD(im) != NULL) + call close (IM_HFD(im)) + + if (protect (IM_HDRFILE(im), QUERY_PROTECTION) == YES) { + iferr (junk = protect (IM_HDRFILE(im), REMOVE_PROTECTION)) + call erract (EA_ERROR) + iferr (junk = protect (Memc[fname], SET_PROTECTION)) + call erract (EA_ERROR) + } + + iferr (call delete (IM_HDRFILE(im))) + call erract (EA_ERROR) + iferr (call rename (Memc[fname], IM_HDRFILE(im))) + call erract (EA_ERROR) + + if (IM_HFD(im) != NULL) + IM_HFD(im) = open (IM_HDRFILE(im), READ_ONLY, TEXT_FILE) + + call sfree (sp) +end diff --git a/sys/imio/iki/stf/stfwgpb.x b/sys/imio/iki/stf/stfwgpb.x new file mode 100644 index 00000000..3a9e8fe8 --- /dev/null +++ b/sys/imio/iki/stf/stfwgpb.x @@ -0,0 +1,174 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include <imhdr.h> +include <imio.h> +include <mach.h> +include "stf.h" + +# STF_WGPB -- Write the group parameter block data back into the pixel file. +# The GPB is described by a structure member list in the STF descriptor. +# The values of the GPB parameters are encoded as FITS cards in the user +# area of the IMIO descriptor. +# +# DLB--11/3/87: Made changes to allow i*2 and i*4 integer parameters in gpb. + +procedure stf_wgpb (im, group, datamin, datamax) + +pointer im # IMIO image descriptor +int group # group to be accessed +real datamin, datamax # new min, max pixel values + +long offset +pointer sp, stf, gpb, lbuf, pp, op +int pfd, pn, sz_param, sz_gpb, i + +int open(), strlen() +bool bval, imgetb() +# changed to short and long for short integers in gpb +short sval, imgets() +long lval, imgetl() +# +real rval, imgetr() +double dval, imgetd() +errchk open, seek +int imaccf() + +string writerr "cannot update group parameter block" +string badtype "illegal group data parameter datatype" + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + stf = IM_KDES(im) + pfd = STF_PFD(stf) + + # Not all images have group parameter blocks. + if (STF_PSIZE(stf) == 0) { + call sfree (sp) + return + } + + # Open the pixel file if not already open. + if (pfd == NULL) { + pfd = open (IM_PIXFILE(im), READ_WRITE, BINARY_FILE) + STF_PFD(stf) = pfd + } + + # Update the values of DATAMIN, DATAMAX. + if (imaccf (im, "DATAMIN") == YES && + imaccf (im, "DATAMAX") == YES) { + + iferr { + call imputr (im, "DATAMIN", datamin) + call imputr (im, "DATAMAX", datamax) + } then + call erract (EA_WARN) + } + + # Allocate a buffer for the GPB. + sz_gpb = STF_PSIZE(stf) / NBITS_BYTE / SZB_CHAR + call salloc (gpb, sz_gpb, TY_CHAR) + + # Extract the binary value of each parameter in the GPB and encode it + # in FITS format in the IMIO user area. + + offset = 0 + for (pn=1; pn <= STF_PCOUNT(stf); pn=pn+1) { + pp = STF_PDES(stf,pn) + op = gpb + offset + + # Fetch the value of the parameter from IMIO and write it into + # the GPB binary data structure. + + switch (P_SPPTYPE(pp)) { + case TY_BOOL: + iferr (bval = imgetb (im, P_PTYPE(pp))) { + call erract (EA_WARN) + bval = false + } + # Memb[(op-1)/SZ_BOOL+1] = bval + if (SZ_INT != SZ_INT32) { + call i64to32 (bval, bval, 1) + call amovc (bval, Memc[op], SZ_INT32) + } else + call amovc (bval, Memc[op], SZ_BOOL) + + # changed case for int to short and long + # to allow i*2 in gpb--dlb 11/3/87 + case TY_SHORT: + iferr (sval = imgets (im, P_PTYPE(pp))) { + call erract (EA_WARN) + sval = 0 + } + call amovc (sval, Memc[op], SZ_SHORT) + + case TY_LONG: + iferr (lval = imgetl (im, P_PTYPE(pp))) { + call erract (EA_WARN) + lval = 0 + } + if (SZ_INT != SZ_INT32) { + call i64to32 (lval, lval, 1) + call amovc (lval, Memc[op], SZ_INT32) + } else + call amovc (lval, Memc[op], SZ_LONG) + + case TY_REAL: + iferr (rval = imgetr (im, P_PTYPE(pp))) { + # Currently with MWCS, WCS cards such as CRVAL, CDi_j, + # etc. (always type real or double) are omitted from the + # header if their value is zero. Hence if the card is + # missing assume a value of zero rather than issue a + # warning. + + # call erract (EA_WARN) + rval = 0.0 + } + # Memr[(op-1)/SZ_REAL+1] = rval + call amovc (rval, Memc[op], SZ_REAL) + + case TY_DOUBLE: + iferr (dval = imgetd (im, P_PTYPE(pp))) { + # Skip warning as assume zero, as above or TY_REAL. + # call erract (EA_WARN) + dval = 0.0D0 + } + # Memd[(op-1)/SZ_DOUBLE+1] = dval + call amovc (dval, Memc[op], SZ_DOUBLE) + + case TY_CHAR: + # Blank fill the string buffer. + do i = 1, P_LEN(pp) + Memc[lbuf+i-1] = ' ' + + # Fetch the string value of the parameter. + iferr (call imgstr (im, P_PTYPE(pp), Memc[lbuf], SZ_LINE)) + call erract (EA_WARN) + + # Replace the EOS delimiter by a blank. + i = strlen (Memc[lbuf]) + Memc[lbuf+i] = ' ' + + # Pack the blank filled array into the GPB. + call chrpak (Memc[lbuf], 1, Memc[gpb+offset], 1, P_LEN(pp)) + + default: + call error (1, badtype) + } + + sz_param = P_PSIZE(pp) / NBITS_BYTE / SZB_CHAR + offset = offset + sz_param + } + + # Write the GPB into the pixfile. The GPB is located at the very end + # of the data storage area for the group. + + offset = (group * STF_SZGROUP(stf) + 1) - sz_gpb + call seek (pfd, offset) + iferr (call write (pfd, Memc[gpb], sz_gpb)) + call error (5, writerr) + + call sfree (sp) +end diff --git a/sys/imio/imaccess.x b/sys/imio/imaccess.x new file mode 100644 index 00000000..cc6d450e --- /dev/null +++ b/sys/imio/imaccess.x @@ -0,0 +1,66 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> + + +# IMACCESS -- Test if an image exists and is accessible with the given access +# mode. If the access mode given is NEW_IMAGE, test if the image name given +# is legal (has a legal extension, i.e., type). YES is returned if the named +# image exists, NO if no image exists with the given name, and ERR if the +# image name is ambiguous (multiple images, e.g. of different types, exist +# with the same name). + +int procedure imaccess (image, acmode) + +char image[ARB] # image name +int acmode # access mode + +int exists, cl_index, cl_size, mode, status +pointer sp, cluster, ksection, section, root, extn, im +int iki_access() +errchk syserrs +pointer immap() + +begin + call smark (sp) + call salloc (cluster, SZ_PATHNAME, TY_CHAR) + call salloc (ksection, SZ_FNAME, TY_CHAR) + call salloc (section, SZ_FNAME, TY_CHAR) + call salloc (root, SZ_PATHNAME, TY_CHAR) + call salloc (extn, SZ_FNAME, TY_CHAR) + + call iki_init() + + call imparse (image, + Memc[cluster], SZ_PATHNAME, + Memc[ksection], SZ_FNAME, + Memc[section], SZ_FNAME, cl_index, cl_size) + + # If an image section, kernel section, or cluster index was specified + # we must actually attempt to open the image to determine if the + # object specified by the full notation exists, otherwise we can just + # call the IKI access function to determine if the cluster exists. + + if (Memc[section] != EOS || Memc[ksection] != EOS || cl_index >= 0) { + mode = acmode + if (acmode == 0) + mode = READ_ONLY + iferr (im = immap (image, mode, 0)) + exists = NO + else { + exists = YES + call imunmap (im) + } + } else { + status = iki_access (image, Memc[root], Memc[extn], acmode) + if (status > 0) + exists = YES + else if (status == 0) + exists = NO + else + call syserrs (SYS_IKIAMBIG, image) + } + + call sfree (sp) + return (exists) +end diff --git a/sys/imio/imaflp.x b/sys/imio/imaflp.x new file mode 100644 index 00000000..27aa64c1 --- /dev/null +++ b/sys/imio/imaflp.x @@ -0,0 +1,70 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMAFLP -- Flip a vector end for end. Optimized for the usual pixel types. +# Pretty slow for DOUBLE and COMPLEX on byte machines, but it is not worth +# optimizing for those cases. + +procedure imaflp (a, npix, sz_pixel) + +char a[ARB], temp +int npix, sz_pixel +int i, left, right, pixel + +begin + switch (sz_pixel) { + case SZ_SHORT: + call imflps (a, npix) + case SZ_LONG: + call imflpl (a, npix) + + default: # flip odd sized elements + left = 1 + right = ((npix-1) * sz_pixel) + 1 + + do pixel = 1, (npix + 1) / 2 { + do i = 0, sz_pixel-1 { + temp = a[right+i] + a[right+i] = a[left+i] + a[left+i] = temp + } + left = left + sz_pixel + right = right - sz_pixel + } + } +end + + +# IMFLPS -- Flip an array of SHORT sized elements. + +procedure imflps (a, npix) + +short a[npix], temp +int npix, i, right + +begin + right = npix + 1 + + do i = 1, (npix + 1) / 2 { + temp = a[right-i] + a[right-i] = a[i] + a[i] = temp + } +end + + +# IMFLPL -- Flip an array of LONG sized elements. + +procedure imflpl (a, npix) + +long a[npix], temp +int npix, i, right + +begin + right = npix + 1 + + do i = 1, (npix + 1) / 2 { + temp = a[right-i] + a[right-i] = a[i] + a[i] = temp + } +end diff --git a/sys/imio/imaplv.x b/sys/imio/imaplv.x new file mode 100644 index 00000000..36a1f315 --- /dev/null +++ b/sys/imio/imaplv.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> + +# IMAPLV -- Transform the logical vector LV (which references an image section) +# into a physical vector (which references the physical image). + +procedure imaplv (im, lv, pv, ndim) + +pointer im +long lv[ndim], pv[IM_MAXDIM] +int ndim +int loff # logical offset (subscript) +int nldims # number of logical dimensions +int i, j # i = logical dim index, j = physical dim index + +begin + i = 1 + nldims = min (IM_NDIM(im), ndim) + + do j = 1, IM_NPHYSDIM(im) { + if (i <= nldims && IM_VMAP(im,i) == j) { + loff = lv[i] + i = i + 1 + } else + loff = 1 + pv[j] = IM_VOFF(im,j) + IM_VSTEP(im,j) * loff + } +end diff --git a/sys/imio/imbln1.x b/sys/imio/imbln1.x new file mode 100644 index 00000000..60b40c0c --- /dev/null +++ b/sys/imio/imbln1.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> + +# IMBLN1 -- Get the length of the axes of a one dimensional subraster. +# Must be called immediately after the get or put call that created the +# buffer. + +procedure imbln1 (imdes, nx) + +pointer imdes +int nx +pointer bdes + +begin + # Get pointer to most recently used buffer descriptor. + bdes = IM_LASTBDES(imdes) + + nx = abs (BD_VE(bdes,1) - BD_VS(bdes,1)) + 1 +end diff --git a/sys/imio/imbln2.x b/sys/imio/imbln2.x new file mode 100644 index 00000000..034a1a45 --- /dev/null +++ b/sys/imio/imbln2.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> + +# IMBLN2 -- Get the length of the axes of a two dimensional subraster. +# Must be called immediately after the get or put call that created the +# buffer. + +procedure imbln2 (imdes, nx, ny) + +pointer imdes +int nx, ny +int i, v[2] +pointer bdes + +begin + # Get pointer to most recently used buffer descriptor. + bdes = IM_LASTBDES(imdes) + + do i = 1, 2 + v[i] = abs (BD_VE(bdes,i) - BD_VS(bdes,i)) + 1 + + nx = v[1] + ny = v[2] +end diff --git a/sys/imio/imbln3.x b/sys/imio/imbln3.x new file mode 100644 index 00000000..8f734ce7 --- /dev/null +++ b/sys/imio/imbln3.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> + +# IMBLN3 -- Get the length of the axes of a three dimensional subraster. +# Must be called immediately after the get or put call that created the +# buffer. + +procedure imbln3 (imdes, nx, ny, nz) + +pointer imdes +int nx, ny, nz +int i, v[3] +pointer bdes + +begin + # Get pointer to most recently used buffer descriptor. + bdes = IM_LASTBDES(imdes) + + do i = 1, 3 + v[i] = abs (BD_VE(bdes,i) - BD_VS(bdes,i)) + 1 + + nx = v[1] + ny = v[2] + nz = v[3] +end diff --git a/sys/imio/imbtran.x b/sys/imio/imbtran.x new file mode 100644 index 00000000..bf3ec201 --- /dev/null +++ b/sys/imio/imbtran.x @@ -0,0 +1,65 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imset.h> +include <imio.h> + +# IMBTRAN -- Transform a point (x,y), possibly lying outside the boundary of +# the N-dimensional image, back into the image using the current boundary +# extension technique. + +procedure imbtran (im, v1, v2, ndim) + +pointer im # image descriptor +long v1[IM_MAXDIM] # input, out of bounds point +long v2[IM_MAXDIM] # transformed point (output) +int ndim # number of dimensions to transform + +int i +long vin, vmax + +begin + switch (IM_VTYBNDRY(im)) { + case BT_NEAREST: + do i = 1, ndim { + vmax = IM_SVLEN(im,i) + vin = v1[i] + + if (vin < 1) + v2[i] = 1 + else if (vin > vmax) + v2[i] = vmax + else + v2[i] = vin + } + + case BT_REFLECT: + do i = 1, ndim { + vmax = IM_SVLEN(im,i) + vin = v1[i] + + if (vin < 1) + v2[i] = 1 + (1 - vin) + else if (vin > vmax) + v2[i] = vmax - (vin - vmax) + else + v2[i] = vin + } + + case BT_WRAP: + do i = 1, ndim { + vmax = IM_SVLEN(im,i) + vin = v1[i] + + while (vin < 1) + vin = vin + vmax + while (vin > vmax) + vin = vin - vmax + v2[i] = vin + } + + default: + do i = 1, ndim + v2[i] = v1[i] + } +end diff --git a/sys/imio/imcopy.x b/sys/imio/imcopy.x new file mode 100644 index 00000000..da7c8b57 --- /dev/null +++ b/sys/imio/imcopy.x @@ -0,0 +1,14 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMCOPY -- Fast copy of an entire image. No fancy sections, type conversions, +# etc. are permitted if this is used. + +procedure imcopy (old, new) + +char old[ARB] # old image +char new[ARB] # new image + +begin + call iki_init() + call iki_copy (old, new) +end diff --git a/sys/imio/imcssz.x b/sys/imio/imcssz.x new file mode 100644 index 00000000..1ba356be --- /dev/null +++ b/sys/imio/imcssz.x @@ -0,0 +1,69 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <plset.h> +include <imhdr.h> +include <imio.h> + +# IMCSSZ -- Compute size of buffer needed to hold the section defined +# by the logical vectors VS and VE. If type conversion is needed, +# must allow space for whichever pixel is largest. If subsampling is +# in use (step size greater than one), must allow extra space for the +# unsampled data. + +long procedure imcssz (im, vs, ve, ndim, dtype, npix, rwflag) + +pointer im # image descriptor +long vs[ARB], ve[ARB] # endpoints of section +int ndim # dimensionality of section +int dtype # datatype of pixels in section +long npix # number of pixels in section (output) +int rwflag # section is to be read or written + +int step, i, sz_pixel, npix_per_line, extra_pix +long buf_size + +int sizeof() + +begin + sz_pixel = max (sizeof(IM_PIXTYPE(im)), sizeof(dtype)) + + if (IM_VMAP(im,1) == 1) + step = abs (IM_VSTEP(im,1)) + else + step = 1 + + # Compute the total number of pixels in the subraster. + + npix_per_line = abs (ve[1] - vs[1]) + 1 + npix = npix_per_line + + for (i=2; i <= ndim; i=i+1) + npix = npix * (abs (ve[i] - vs[i]) + 1) + + # If the sample step size is greater than one, but less than + # IM_MAXSTEP, allow extra space for the final unsampled line. + # If not subsampling, and the buffer is for writing, add extra + # space so that writes can be an integral number of device + # blocks in size. + + extra_pix = 0 + if (step != 1) { + if (step <= IM_MAXSTEP && rwflag == IM_READ) + extra_pix = (step - 1) * npix_per_line + } else if (rwflag == IM_WRITE) + extra_pix = (IM_PHYSLEN(im,1) - IM_SVLEN(im,1)) + + # If accessing a mask image with range list i/o, the maximum size + # range list may be larger than the size of an image line in pixels. + # Allow some extra space to permit such range lists to be read in + # without buffer overflow; a runtime error is still possible if the + # subraster contains multiple lines, and an individual range list + # exceeds the length of the line in which it must be stored. + + if (and (IM_PLFLAGS(im), PL_RLIO) != 0) + extra_pix = max (extra_pix, RL_MAXLEN(IM_PL(im)) - npix_per_line) + + buf_size = (npix + extra_pix) * sz_pixel # size buf, chars + + return (buf_size) +end diff --git a/sys/imio/imdelete.x b/sys/imio/imdelete.x new file mode 100644 index 00000000..785d5c60 --- /dev/null +++ b/sys/imio/imdelete.x @@ -0,0 +1,57 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMDELETE -- Delete an image. + +procedure imdelete (image) + +char image[ARB] + +char cache[SZ_FNAME], fname[SZ_FNAME], extn[SZ_FNAME] +char root[SZ_FNAME], src[SZ_FNAME] +int status, len, ip + +int envgets(), strlen(), iki_access(), imaccess() +bool streq() + +begin + # Delete a cached version of the file. + if (envgets ("cache", cache, SZ_PATHNAME) > 0) { + status = iki_access (image, root, extn, READ_ONLY) + len = strlen (root) + for (ip = len; ip > 0; ip=ip-1) { + if (root[ip] == '/') { + call strcpy (root[ip+1], root, SZ_FNAME) + break + } + } + + # Make sure the name has the image extension. + len = strlen (image) + if (! streq (extn, image[len-strlen(extn)+1])) { + call strcat (".", root, SZ_FNAME) + call strcat (extn, root, SZ_FNAME) + } + + # Note that if the file in the cache was added using + # a full path and/or image type extension, it will not + # be found in the cache and deleted. + if (status > 0) { + call fclookup (cache, image, fname, extn, SZ_FNAME) + if (fname[1] != EOS) { + call fcdelete (cache, fname) + + call fcsrc (cache, image, src, SZ_FNAME) + if (src[1] != EOS) { + call fclookup (cache, src, fname, extn, SZ_FNAME) + call fcdelete (cache, fname) + call fcdelete (cache, src) + } + } + } + } + + if (imaccess (image, READ_ONLY) == YES) { + call iki_init() + call iki_delete (image) + } +end diff --git a/sys/imio/imdmap.x b/sys/imio/imdmap.x new file mode 100644 index 00000000..9d4e7c70 --- /dev/null +++ b/sys/imio/imdmap.x @@ -0,0 +1,110 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <error.h> +include <imset.h> +include <imhdr.h> +include <imio.h> + +# IMDMAP -- Map an image display frame as an imagefile. Equivalent to +# the ordinary immap, except that the pixel storage file is the image +# frame buffer. The special pixel storage file is pre-opened with +# IMDOPEN. Upon the first pixel access, IMIO normally opens the pixfile. +# In this case, it sees that the file has already been opened (as a +# special device as it turns out), and simply uses it. + +pointer procedure imdmap (device, access_mode, imdopen) + +char device[ARB] # graphcap name of display device to be opened +int access_mode # display access mode +extern imdopen() # device FIO open procedure +int imdopen() + +int pfd, pixel_mode +pointer sp, devinfo, devname, im, tty + +bool streq(), ttygetb() +pointer immap(), ttygdes() +int ttygeti(), ttygets(), envgets(), btoi() +errchk imdopen, immap, syserrs + +begin + call smark (sp) + call salloc (devinfo, SZ_LINE, TY_CHAR) + call salloc (devname, SZ_FNAME, TY_CHAR) + + # Determine the display access mode. Write permission is always + # required, even to read from a display device. Write only mode + # is however desirable for the display, to avoid unnecessary i/o + # when faulting the file buffer. + + switch (access_mode) { + case READ_ONLY: + pixel_mode = READ_WRITE + case READ_WRITE: + pixel_mode = READ_WRITE + case WRITE_ONLY: + pixel_mode = WRITE_ONLY + default: + # Cannot create an image on a special device. + call syserrs (SYS_IMDEVOPN, device) + } + + # Open an image header for the special device. + im = immap ("dev$null", NEW_IMAGE, 0) + + # Read the graphcap entry for the device and fetch the device + # parameters. + + if (streq (device, "stdimage")) { + if (envgets ("stdimage", Memc[devname], SZ_FNAME) <= 0) { + call imunmap (im) + call syserrs (SYS_IMDEVOPN, device) + } + } else + call strcpy (device, Memc[devname], SZ_FNAME) + + iferr (tty = ttygdes (Memc[devname])) { + call imunmap (im) + call erract (EA_ERROR) + } + + if (ttygets (tty, "DD", Memc[devinfo], SZ_LINE) <= 0) { + call imunmap (im) + call ttycdes (tty) + call syserrs (SYS_IMDEVOPN, device) + } + + IM_PIXTYPE(im) = TY_SHORT + IM_LEN(im,1) = ttygeti (tty, "xr") + IM_LEN(im,2) = ttygeti (tty, "yr") + IM_LEN(im,3) = ttygeti (tty, "cn") + IM_LEN(im,4) = btoi(ttygetb (tty, "LC")) + IM_NDIM(im) = 2 + IM_MIN(im) = real (ttygeti (tty, "z0")) + IM_MAX(im) = real (ttygeti (tty, "zr") - 1.) + IM_MIN(im) + IM_LIMTIME(im) = IM_MTIME(im) + 1 + IM_PIXOFF(im) = 1 + IM_HGMOFF(im) = NULL + IM_BLIST(im) = NULL + IM_NPHYSDIM(im) = 2 + + call amovl (IM_LEN(im,1), IM_PHYSLEN(im,1), IM_MAXDIM) + call amovl (IM_LEN(im,1), IM_SVLEN(im,1), IM_MAXDIM) + + # Open the display device. + pfd = imdopen (Memc[devinfo], pixel_mode) + if (pfd == ERR) { + call imunmap (im) + call syserrs (SYS_IMDEVOPN, device) + } + + call imseti (im, IM_PIXFD, pfd) + call imseti (im, IM_WHEADER, NO) + call imsetbuf (pfd, im) + + call ttycdes (tty) + call sfree (sp) + + return (im) +end diff --git a/sys/imio/imerr.x b/sys/imio/imerr.x new file mode 100644 index 00000000..8b2aa6b2 --- /dev/null +++ b/sys/imio/imerr.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMERR -- Format an error message for the named image and call error. +# format of error message: ERROR (nnn, "message ('imname')"). + +procedure imerr (image_name, errcode) + +char image_name[ARB] +int errcode + +begin + call syserrs (errcode, image_name) +end diff --git a/sys/imio/imfls.gx b/sys/imio/imfls.gx new file mode 100644 index 00000000..49016816 --- /dev/null +++ b/sys/imio/imfls.gx @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> + +# IMFLS? -- Flush the output buffer, if necessary. Convert the datatype +# of the pixels upon output, if the datatype of the pixels in the imagefile +# is different than that requested by the calling program. + +procedure imfls$t (imdes) + +pointer imdes +pointer bdes, bp +errchk imflsh + +begin + # Ignore the flush request if the output buffer has already been + # flushed. + + if (IM_FLUSH(imdes) == YES) { + bdes = IM_OBDES(imdes) + bp = BD_BUFPTR(bdes) + + # Convert datatype of pixels, if necessary, and flush buffer. + if (IM_PIXTYPE(imdes) != TY_PIXEL || SZ_INT != SZ_INT32) { + call impak$t (Memc[bp], Memc[bp], BD_NPIX(bdes), + IM_PIXTYPE(imdes)) + } + + call imflsh (imdes, bp, BD_VS(bdes,1), BD_VE(bdes,1), BD_NDIM(bdes)) + + IM_FLUSH(imdes) = NO + } +end diff --git a/sys/imio/imflsh.x b/sys/imio/imflsh.x new file mode 100644 index 00000000..c0d54d6d --- /dev/null +++ b/sys/imio/imflsh.x @@ -0,0 +1,60 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include <imio.h> + +# IMFLSH -- Flush the output buffer to the pixel storage file (not +# dependent on the datatype of the pixels). The mapping of the subraster +# in the output buffer to the imagefile is described by the section +# descriptor vectors in the buffer descriptor. Images up to IM_MAXDIM +# dimensions are permitted, and each dimension may be accessed in either +# the forward or reverse direction. + +procedure imflsh (im, bp, vs, ve, ndim) + +pointer im # image descriptor +pointer bp # pointer to buffer containing the data +long vs[ARB], ve[ARB] # logical coordinates of section to be written +int ndim # dimensionality of the section + +pointer line +long pvs[IM_MAXDIM], pve[IM_MAXDIM] +long v[IM_MAXDIM], vinc[IM_MAXDIM] +int sz_pixel, sz_dtype, inbounds, npix, xstep +int imsinb(), imloop(), sizeof() +errchk imwrpx, imwbpx +include <szpixtype.inc> + +begin + sz_dtype = sizeof (IM_PIXTYPE(im)) + sz_pixel = pix_size[IM_PIXTYPE(im)] + + # Check if the section extends out of bounds. + inbounds = imsinb (im, vs, ve, ndim) + if (inbounds == ERR) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + # Map the logical section into a physical section. Prepare the + # section descriptor do-loop index and increment vectors V, VINC. + + call imaplv (im, vs, pvs, ndim) + call imaplv (im, ve, pve, ndim) + call imsslv (im, pvs, pve, v, vinc, npix) + + line = bp + + # Write the section to the output image, line segment by line segment, + # advancing through the dimensions in storage order (leftmost subscript + # varies fastest). + + repeat { + # Call IMWRPX directly if section is inbounds. + xstep = vinc[1] + if (inbounds == YES) + call imwrpx (im, Memc[line], npix, v, xstep) + else + call imwbpx (im, Memc[line], npix, v, xstep) + line = line + npix * sz_pixel + } until (imloop (v, pvs, pve, vinc, IM_NPHYSDIM(im)) == LOOP_DONE) +end diff --git a/sys/imio/imflush.x b/sys/imio/imflush.x new file mode 100644 index 00000000..32cd2bc7 --- /dev/null +++ b/sys/imio/imflush.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> + +# IMFLUSH -- Flush the output buffer. The output buffer may contain +# pixels of any datatype. The entry point of the datatype specific +# flush procedure is saved in the image descriptor by IMPGS?. + +procedure imflush (imdes) + +pointer imdes + +begin + if (IM_PFD(imdes) != NULL && IM_FLUSH(imdes) == YES) { + call zcall1 (IM_FLUSHEPA(imdes), imdes) + call flush (IM_PFD(imdes)) + } +end diff --git a/sys/imio/imgclust.x b/sys/imio/imgclust.x new file mode 100644 index 00000000..ca075cfb --- /dev/null +++ b/sys/imio/imgclust.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMGCLUSTER -- Get the cluster name of an image, i.e., the name of the cluster +# to which the image belongs, minus the cluster index and image section, if any. + +procedure imgcluster (imspec, cluster, maxch) + +char imspec[ARB] # full image specification +char cluster[ARB] # receives root image name +int maxch + +int cl_index, cl_size +pointer sp, ksection, section + +begin + call smark (sp) + call salloc (ksection, SZ_FNAME, TY_CHAR) + call salloc (section, SZ_FNAME, TY_CHAR) + + call imparse (imspec, cluster, maxch, Memc[ksection], SZ_FNAME, + Memc[section], SZ_FNAME, cl_index, cl_size) + + call sfree (sp) +end diff --git a/sys/imio/imggs.gx b/sys/imio/imggs.gx new file mode 100644 index 00000000..70cc445e --- /dev/null +++ b/sys/imio/imggs.gx @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMGGS? -- Get a general section. + +pointer procedure imggs$t (imdes, vs, ve, ndim) + +pointer imdes +long vs[IM_MAXDIM], ve[IM_MAXDIM] +int ndim +long totpix +pointer bp, imggsc() +errchk imggsc + +begin + bp = imggsc (imdes, vs, ve, ndim, TY_PIXEL, totpix) + if (IM_PIXTYPE(imdes) != TY_PIXEL) + call imupk$t (Mem$t[bp], Mem$t[bp], totpix, IM_PIXTYPE(imdes)) + return (bp) +end diff --git a/sys/imio/imggsc.x b/sys/imio/imggsc.x new file mode 100644 index 00000000..caccc6a3 --- /dev/null +++ b/sys/imio/imggsc.x @@ -0,0 +1,105 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <plset.h> +include <imhdr.h> +include <imio.h> + +# IMGGSC -- Get a general section, any datatype (called by one of the typed +# procedures, which subsequently convert the datatype of the pixels returned +# by this routine). The mapping of the subraster in the input buffer to the +# imagefile is described by the section descriptor vectors VS and VE. Images +# of up to IM_MAXDIM dimensions are permitted, and each dimension may be +# accessed in either the forward or reverse direction. + +pointer procedure imggsc (im, vs, ve, ndim, dtype, totpix) + +pointer im # image descriptor +long vs[ARB], ve[ARB] # logical coords of corners of section +int ndim # dimensionality of section +int dtype # datatype of pixels desired +long totpix # total pixels in section (output) + +bool rlio +pointer sp, px, bp, line, rl_high +long v[IM_MAXDIM], vinc[IM_MAXDIM] +long pvs[IM_MAXDIM], pve[IM_MAXDIM] +int sz_pixel, inbounds, npix, xstep, n + +pointer imgibf() +int imsinb(), imloop(), pl_p2ri(), sizeof() +errchk imgibf, imrdpx, imrbpx +include <szpixtype.inc> + +begin + #sz_pixel = sizeof(IM_PIXTYPE(im)) + #sz_pixel = max ( sizeof(dtype), sizeof(IM_PIXTYPE(im)) ) + #sz_pixel = pix_size[IM_PIXTYPE(im)] + sz_pixel = sizeof(IM_PIXTYPE(im)) + rlio = (and (IM_PLFLAGS(im), PL_RLIO+PL_FAST) == PL_RLIO) + + # Check that the section does not extend out of bounds. + inbounds = imsinb (im, vs, ve, ndim) + if (inbounds == ERR) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + # Get an (input) buffer to put the pixels into. Map the logical + # section into a physical section. Prepare the section descriptor + # do-loop index and increment vectors V, VINC. + + bp = imgibf (im, vs, ve, ndim, dtype) + call imaplv (im, vs, pvs, ndim) + call imaplv (im, ve, pve, ndim) + call imsslv (im, pvs, pve, v, vinc, npix) + + # A temporary pixel buffer is required for RLIO conversions. + if (rlio) { + call smark (sp) + call salloc (px, npix, TY_INT) + } + + line = bp + totpix = 0 + rl_high = bp - 1 + + # Read the section into the input buffer, line segment by line segment, + # advancing through the dimensions in storage order (leftmost subscript + # varies fastest). + + repeat { + xstep = vinc[1] + + # Convert the pixel array to a range list? (image masks). This is + # done more efficiently at a lower level if no complex geometric + # transformations are required (due to sections or OOB references). + + if (rlio) { + if (inbounds == YES) + call imrdpx (im, Memi[px], npix, v, xstep) + else + call imrbpx (im, Memi[px], npix, v, xstep) + + if (rl_high >= line) + call imerr (IM_NAME(im), SYS_IMRLOVFL) + else { + n = pl_p2ri (Memi[px], 1, Memc[line], npix) + rl_high = line + (n * RL_LENELEM * sz_pixel) - 1 + } + + } else { + if (inbounds == YES) + call imrdpx (im, Memc[line], npix, v, xstep) + else + call imrbpx (im, Memc[line], npix, v, xstep) + } + + line = line + (npix * sz_pixel) + totpix = totpix + npix + + } until (imloop (v, pvs, pve, vinc, IM_NPHYSDIM(im)) == LOOP_DONE) + + if (rlio) + call sfree (sp) + + return ((bp - 1) / sizeof(dtype) + 1) +end diff --git a/sys/imio/imgibf.x b/sys/imio/imgibf.x new file mode 100644 index 00000000..9155ae78 --- /dev/null +++ b/sys/imio/imgibf.x @@ -0,0 +1,65 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> + +# IMGIBF -- Get an input buffer. + +pointer procedure imgibf (im, vs, ve, ndim, dtype) + +pointer im +long vs[ARB], ve[ARB] +int dtype, ndim + +pointer bdes +int i +long nget, nchars, totpix + +long imcssz() +errchk imopsf, calloc, realloc, mfree, malloc + +begin + # If first input transfer, allocate and initialize array of + # input buffer descriptors. + + if (IM_IBDES(im) == NULL) { + call imopsf (im) + call calloc (IM_IBDES(im), LEN_BDES * IM_VNBUFS(im), TY_STRUCT) + } + + # Compute pointer to the next input buffer descriptor. + # Increment NGET, the count of the number of GETPIX calls. + + nget = IM_NGET(im) + bdes = IM_IBDES(im) + mod (nget, IM_VNBUFS(im)) * LEN_BDES + IM_NGET(im) = nget + 1 + + # Compute the size of the buffer needed. Check buffer + # descriptor to see if the old buffer is the right size. + # If so, use it, otherwise make a new one. + + nchars = imcssz (im, vs, ve, ndim, dtype, totpix, IM_READ) + + if (nchars < BD_BUFSIZE(bdes)) + call realloc (BD_BUFPTR(bdes), nchars, TY_CHAR) + else if (nchars > BD_BUFSIZE(bdes)) { + call mfree (BD_BUFPTR(bdes), TY_CHAR) + call malloc (BD_BUFPTR(bdes), nchars, TY_CHAR) + } + + # Save section coordinates, datatype in buffer descriptor, and + # return buffer pointer to calling program. + + IM_LASTBDES(im) = bdes + BD_BUFSIZE(bdes) = nchars + BD_DTYPE(bdes) = dtype + BD_NPIX(bdes) = totpix + BD_NDIM(bdes) = ndim + + do i = 1, ndim { + BD_VS(bdes,i) = vs[i] + BD_VE(bdes,i) = ve[i] + } + + return (BD_BUFPTR(bdes)) # return ptr to CHAR +end diff --git a/sys/imio/imgimage.x b/sys/imio/imgimage.x new file mode 100644 index 00000000..9e81d409 --- /dev/null +++ b/sys/imio/imgimage.x @@ -0,0 +1,40 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMGIMAGE -- Get the name of an individual image within a cluster of images, +# i.e., the image name minus any image section. + +procedure imgimage (imspec, image, maxch) + +char imspec[ARB] # full image specification +char image[ARB] # receives image name +int maxch + +int cl_index, cl_size +pointer sp, cluster, ksection, section + +begin + call smark (sp) + call salloc (cluster, SZ_PATHNAME, TY_CHAR) + call salloc (ksection, SZ_FNAME, TY_CHAR) + call salloc (section, SZ_FNAME, TY_CHAR) + + call imparse (imspec, + Memc[cluster], SZ_PATHNAME, + Memc[ksection], SZ_FNAME, + Memc[section], SZ_FNAME, cl_index, cl_size) + + if (cl_index >= 0 && cl_size == -1) { + call sprintf (image, maxch, "%s[%d]") + call pargstr (Memc[cluster]) + call pargi (cl_index) + } else if (cl_index >= 0 && cl_size > 0) { + call sprintf (image, maxch, "%s[%d/%d]") + call pargstr (Memc[cluster]) + call pargi (cl_index) + call pargi (cl_size) + } else + call strcpy (Memc[cluster], image, maxch) + + call strcat (Memc[ksection], image, maxch) + call sfree (sp) +end diff --git a/sys/imio/imgl1.gx b/sys/imio/imgl1.gx new file mode 100644 index 00000000..5008b291 --- /dev/null +++ b/sys/imio/imgl1.gx @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> + +# IMGL1? -- Get a line from an apparently one dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure imgl1$t (im) + +pointer im +int fd, nchars +long offset +pointer bp, imggs$t(), freadp() +errchk imopsf + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_PIXEL) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + + offset = IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_PIXEL + ifnoerr (bp = (freadp (fd, offset, nchars) - 1) / SZ_PIXEL + 1) + return (bp) + } + return (imggs$t (im, long(1), IM_LEN(im,1), 1)) + } +end diff --git a/sys/imio/imgl2.gx b/sys/imio/imgl2.gx new file mode 100644 index 00000000..8dfd1751 --- /dev/null +++ b/sys/imio/imgl2.gx @@ -0,0 +1,47 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include <imio.h> + +# IMGL2? -- Get a line from an apparently two dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure imgl2$t (im, linenum) + +pointer im # image header pointer +int linenum # line to be read + +int fd, nchars +long vs[2], ve[2], offset +pointer bp, imggs$t(), freadp() +errchk imopsf, imerr + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_PIXEL) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + if (linenum < 1 || linenum > IM_LEN(im,2)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + offset = (linenum - 1) * IM_PHYSLEN(im,1) * SZ_PIXEL + + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_PIXEL + ifnoerr (bp = (freadp (fd, offset, nchars) - 1) / SZ_PIXEL + 1) + return (bp) + } + + vs[1] = 1 + ve[1] = IM_LEN(im,1) + vs[2] = linenum + ve[2] = linenum + + return (imggs$t (im, vs, ve, 2)) + } +end diff --git a/sys/imio/imgl3.gx b/sys/imio/imgl3.gx new file mode 100644 index 00000000..eed65b92 --- /dev/null +++ b/sys/imio/imgl3.gx @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include <imio.h> + +# IMGL3? -- Get a line from an apparently three dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure imgl3$t (im, line, band) + +pointer im # image header pointer +int line # line number within band +int band # band number + +int fd, nchars +long vs[3], ve[3], offset +pointer bp, imggs$t(), freadp() +errchk imopsf, imerr + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_PIXEL) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + if (line < 1 || line > IM_LEN(im,2) || + band < 1 || band > IM_LEN(im,3)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + offset = (((band - 1) * IM_PHYSLEN(im,2) + line - 1) * + IM_PHYSLEN(im,1)) * SZ_PIXEL + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_PIXEL + ifnoerr (bp = (freadp (fd, offset, nchars) - 1) / SZ_PIXEL + 1) + return (bp) + } + + vs[1] = 1 + ve[1] = IM_LEN(im,1) + vs[2] = line + ve[2] = line + vs[3] = band + ve[3] = band + + return (imggs$t (im, vs, ve, 3)) + } +end diff --git a/sys/imio/imgnl.gx b/sys/imio/imgnl.gx new file mode 100644 index 00000000..dde3d356 --- /dev/null +++ b/sys/imio/imgnl.gx @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMGNL -- Get the next line from an image of any dimension or datatype. +# This is a sequential operator. The index vector V should be initialized +# to the first line to be read before the first call. Each call increments +# the leftmost subscript by one, until V equals IM_LEN, at which time EOF +# is returned. + +int procedure imgnl$t (imdes, lineptr, v) + +pointer imdes +pointer lineptr # on output, points to the pixels +long v[IM_MAXDIM] # loop counter +int npix, dtype, imgnln() +errchk imgnln + +begin + npix = imgnln (imdes, lineptr, v, TY_PIXEL) + + if (npix != EOF) { + dtype = IM_PIXTYPE(imdes) + if (dtype != TY_PIXEL) + call imupk$t (Mem$t[lineptr], Mem$t[lineptr], npix, dtype) + } + + return (npix) +end diff --git a/sys/imio/imgnln.x b/sys/imio/imgnln.x new file mode 100644 index 00000000..96bc7524 --- /dev/null +++ b/sys/imio/imgnln.x @@ -0,0 +1,105 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include <imio.h> + +# IMGNLN -- Get the next line from an image of any dimension or datatype. +# This is a sequential operator. The index vector V should be initialized +# to the first line to be read before the first call. Each call increments +# the leftmost subscript by one, until V equals IM_LEN, at which time EOF +# is returned. + +int procedure imgnln (im, lineptr, v, dtype) + +pointer im +pointer lineptr # on output, points to the pixels +long v[IM_MAXDIM] # loop counter +int dtype # eventual datatype of pixels + +int dim, ndim, junk, sz_pixel, fd, nchars, pixtype +long lineoff, line, band, offset +long vs[IM_MAXDIM], ve[IM_MAXDIM], unit_v[IM_MAXDIM], npix + +int imloop() +pointer imggsc(), freadp() +errchk imggsc, imerr, imopsf +define retry_ 91 +define oob_ 92 +define misaligned_ 93 +include <szpixtype.inc> +data unit_v /IM_MAXDIM * 1/ + +begin + ndim = IM_NDIM(im) + if (ndim == 0) + return (EOF) + + npix = IM_LEN(im,1) # read entire line + pixtype = IM_PIXTYPE(im) + sz_pixel = pix_size[pixtype] + + # Perform "zero trip" check (V >= VE), before entering "loop". + if (v[ndim] > IM_LEN(im,ndim)) + return (EOF) +retry_ + if (IM_FAST(im) == YES && pixtype == dtype && ndim <= 3) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + goto retry_ + } + + # Lineoff is the dimensionless line offset in the pixel storage + # file (which we assume to be in line storage mode). + + lineoff = 0 + if (ndim > 1) { + line = v[2] + if (line < 1 || line > IM_LEN(im,2)) + goto oob_ + lineoff = line - 1 + if (ndim > 2) { + band = v[3] + if (band < 1 || band > IM_LEN(im,3)) +oob_ call imerr (IM_NAME(im), SYS_IMREFOOB) + lineoff = lineoff + (band - 1) * IM_PHYSLEN(im,2) + } + } + + # Reference directly into the FIO buffer. If the image line + # straddles a FIO block boundary freadp calls error and we must + # use a separate buffer. + + offset = lineoff * IM_PHYSLEN(im,1) * sz_pixel + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * sz_pixel + iferr (lineptr = (freadp (fd, offset, nchars) - 1) / sz_pixel + 1) + goto misaligned_ + + } else { +misaligned_ + # Prepare section descriptor vectors. + vs[1] = 1 + ve[1] = npix + do dim = 2, ndim { + vs[dim] = v[dim] + ve[dim] = v[dim] + } + + # Get the line. + lineptr = imggsc (im, vs, ve, ndim, dtype, junk) + } + + # Increment loop vector (cannot use nested loops since the dimension + # of the image is variable). Note this loop vector references + # logical section coordinates. + + if (ndim == 1) + v[1] = IM_LEN(im,1) + 1 + else if (ndim == 2 && IM_FAST(im) == YES) + v[2] = v[2] + 1 + else + junk = imloop (v, unit_v, IM_LEN(im,1), unit_v, ndim) + + return (npix) +end diff --git a/sys/imio/imgobf.x b/sys/imio/imgobf.x new file mode 100644 index 00000000..8dc5f3a1 --- /dev/null +++ b/sys/imio/imgobf.x @@ -0,0 +1,62 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> + +# IMGOBF -- Get output buffer. + +pointer procedure imgobf (im, vs, ve, ndim, dtype) + +pointer im, bdes +int ndim, dtype, i +long vs[ndim], ve[ndim] +long nchars, totpix, imcssz(), clktime() +int sizeof() + +errchk imopsf, malloc, realloc, calloc + +include <szpixtype.inc> + +begin + # If first write, and if new image, create pixel storage file, + # otherwise open pixel storage file. Allocate and initialize + # output buffer descriptor. + + if (IM_OBDES(im) == NULL) { + call imopsf (im) + call calloc (IM_OBDES(im), LEN_BDES, TY_STRUCT) + IM_MTIME(im) = clktime (long(0)) + IM_SVMTIME(im) = IM_MTIME(im) + } + + bdes = IM_OBDES(im) + + # Compute the size of buffer needed. A few extra chars are added + # to guarantee that there won't be a memory violation when + # writing a full physical length line. + + nchars = imcssz (im, vs, ve, ndim, dtype, totpix, IM_WRITE) + + if (nchars < BD_BUFSIZE(bdes)) + call realloc (BD_BUFPTR(bdes), nchars, TY_CHAR) + else if (nchars > BD_BUFSIZE(bdes)) { + call mfree (BD_BUFPTR(bdes), TY_CHAR) + call malloc (BD_BUFPTR(bdes), nchars, TY_CHAR) + } + + # Save section coordinates, datatype of pixels in buffer + # descriptor, and return buffer pointer to calling program. + + IM_LASTBDES(im) = bdes + BD_BUFSIZE(bdes) = nchars + BD_DTYPE(bdes) = dtype + BD_NPIX(bdes) = totpix + BD_NDIM(bdes) = ndim + + do i = 1, ndim { + BD_VS(bdes,i) = vs[i] + BD_VE(bdes,i) = ve[i] + } + + return ((BD_BUFPTR(bdes) - 1) / sizeof(dtype) + 1) +end diff --git a/sys/imio/imgs1.gx b/sys/imio/imgs1.gx new file mode 100644 index 00000000..ab94d99b --- /dev/null +++ b/sys/imio/imgs1.gx @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMGS1? -- Get a section from an apparently one dimensional image. + +pointer procedure imgs1$t (im, x1, x2) + +pointer im +int x1, x2 +pointer imggs$t(), imgl1$t() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1)) + return (imgl1$t (im)) + else + return (imggs$t (im, long(x1), long(x2), 1)) +end diff --git a/sys/imio/imgs2.gx b/sys/imio/imgs2.gx new file mode 100644 index 00000000..d62c44db --- /dev/null +++ b/sys/imio/imgs2.gx @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMGS2? -- Get a section from an apparently two dimensional image. + +pointer procedure imgs2$t (im, x1, x2, y1, y2) + +pointer im +int x1, x2, y1, y2 +long vs[2], ve[2] +pointer imggs$t(), imgl2$t() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1) && y1 == y2) + return (imgl2$t (im, y1)) + else { + vs[1] = x1 + ve[1] = x2 + + vs[2] = y1 + ve[2] = y2 + + return (imggs$t (im, vs, ve, 2)) + } +end diff --git a/sys/imio/imgs3.gx b/sys/imio/imgs3.gx new file mode 100644 index 00000000..4179c84f --- /dev/null +++ b/sys/imio/imgs3.gx @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMGS3? -- Get a section from an apparently three dimensional image. + +pointer procedure imgs3$t (im, x1, x2, y1, y2, z1, z2) + +pointer im +int x1, x2, y1, y2, z1, z2 +long vs[3], ve[3] +pointer imggs$t(), imgl3$t() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1) && y1 == y2 && z1 == z2) + return (imgl3$t (im, y1, z1)) + else { + vs[1] = x1 + ve[1] = x2 + + vs[2] = y1 + ve[2] = y2 + + vs[3] = z1 + ve[3] = z2 + + return (imggs$t (im, vs, ve, 3)) + } +end diff --git a/sys/imio/imgsect.x b/sys/imio/imgsect.x new file mode 100644 index 00000000..c41fa1b9 --- /dev/null +++ b/sys/imio/imgsect.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMGSECTION -- Get the image section field from an image specifcation. + +procedure imgsection (imspec, section, maxch) + +char imspec[ARB] # full image specifcation +char section[ARB] # receives image section +int maxch + +int cl_index, cl_size +pointer sp, cluster, ksection + +begin + call smark (sp) + call salloc (cluster, SZ_PATHNAME, TY_CHAR) + call salloc (ksection, SZ_FNAME, TY_CHAR) + + call imparse (imspec, Memc[cluster], SZ_PATHNAME, + Memc[ksection], SZ_FNAME, section, maxch, cl_index, cl_size) + + call sfree (sp) +end diff --git a/sys/imio/iminie.x b/sys/imio/iminie.x new file mode 100644 index 00000000..1d019131 --- /dev/null +++ b/sys/imio/iminie.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> + +# IM_INIT_NEWIMAGE -- Initialize the header of a new image. + +procedure im_init_newimage (im, len_imhdr) + +pointer im +int len_imhdr +long clktime() + +begin + call strcpy ("imhdr", IM_MAGIC(im), SZ_IMMAGIC) + IM_HDRLEN(im) = len_imhdr + IM_PIXTYPE(im) = DEF_PIXTYPE + IM_CTIME(im) = clktime (long(0)) + IM_MTIME(im) = IM_CTIME(im) + IM_TITLE(im) = EOS + IM_HISTORY(im) = EOS + Memc[IM_USERAREA(im)] = EOS +end diff --git a/sys/imio/imioff.x b/sys/imio/imioff.x new file mode 100644 index 00000000..bec668b3 --- /dev/null +++ b/sys/imio/imioff.x @@ -0,0 +1,114 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <config.h> +include <imhdr.h> +include <imio.h> +include <mach.h> + +# IMIOFF -- Initialize the physical dimensions of a new image. Compute and set +# the absolute file offsets of the major components of the pixel storage file. + +procedure imioff (im, pixoff, compress, devblksz) + +pointer im # image descriptor +long pixoff # file offset of first pixel +int compress # if set, do not align image lines +int devblksz # FIO device block size + +real impkden, envgetr() +long offset, temp1, temp2, imnote() +int ndim, dim, sz_pixel, lblksize, pblksize +errchk imerr + +include <szpixtype.inc> + +begin + sz_pixel = pix_size[IM_PIXTYPE(im)] + pblksize = max (devblksz, SZ_VMPAGE) + + if (compress == YES) + lblksize = 1 + else + lblksize = devblksz + + # Set the offset of the pixel storage area. Compute the physical + # dimensions of the axes of the image. If image compression is + # selected, the logical and physical lengths of the axes will be + # the same. Otherwise, the physical length of each line of the + # image will be increased to fill an integral number of device blocks. + + IM_PIXOFF(im) = pixoff + call amovl (IM_LEN(im,1), IM_PHYSLEN(im,1), IM_MAXDIM) + call amovl (IM_LEN(im,1), IM_SVLEN(im,1), IM_MAXDIM) + + ndim = IM_NDIM(im) + + # If ndim was not explicitly set, compute it by counting the number + # of nonzero dimensions. + + if (ndim == 0) { + for (ndim=1; IM_LEN(im,ndim) > 0 && ndim <= IM_MAXDIM; + ndim=ndim+1) + ; + ndim = ndim - 1 + IM_NDIM(im) = ndim + } + IM_NPHYSDIM(im) = ndim + + # Make sure dimension stuff makes sense. + if (ndim < 0 || ndim > IM_MAXDIM) + call imerr (IM_NAME(im), SYS_IMNDIM) + + do dim = 1, ndim + if (IM_LEN(im,dim) <= 0) + call imerr (IM_NAME(im), SYS_IMDIMLEN) + + # Set the unused higher dimensions to 1. This makes is possible to + # access the image as if it were higher dimensional, and in a way it + # truely is. + + do dim = ndim + 1, IM_MAXDIM + IM_LEN(im,dim) = 1 + + if (lblksize > 1) { + temp1 = pixoff + IM_LEN(im,1) * sz_pixel + temp2 = temp1 + call imalign (temp2, lblksize) + + # Only block lines if the packing density is above a certain + # threshold. Alignment is disabled if compress=YES since lblksize + # will have been set to 1. + + iferr (impkden = envgetr ("impkden")) + impkden = IM_PACKDENSITY + + if (real(temp1-pixoff) / real(temp2-pixoff) >= impkden) + IM_PHYSLEN(im,1) = (temp2 - pixoff) / sz_pixel + } + + # Set the offsets of the histogram pixels and the bad pixel list. + # The HGMOFF offset marks the end of the pixel segment. + + offset = imnote (im, IM_LEN(im,1)) + call imalign (offset, pblksize) + IM_HGMOFF(im) = offset + + offset = offset + (MAX_HGMLEN * SZ_REAL) + call imalign (offset, lblksize) + IM_BLIST(im) = offset +end + + +# IMALIGN -- Advance "offset" to the next block boundary. + +procedure imalign (offset, blksize) + +long offset +int blksize, diff + +begin + diff = mod (offset-1, max (1, blksize)) + if (diff != 0) + offset = offset + (blksize - diff) +end diff --git a/sys/imio/imisec.x b/sys/imio/imisec.x new file mode 100644 index 00000000..9a4735fe --- /dev/null +++ b/sys/imio/imisec.x @@ -0,0 +1,227 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> +include <ctype.h> +include <syserr.h> +include <imhdr.h> +include <imio.h> + +define FIRST 1 +define LAST MAX_LONG + +.help imisec +.nf ___________________________________________________________________________ +IMISEC -- Translate a section specification string (passed as a suffix +to the imagefile filename) into a set of logical to physical transformation +vectors. + +The image section notation is used to access portions of an image, to reduce +the dimensionality of an image, to reverse the coordinates of any of the axes +of an image, and so on. Since this facility is built into IMIO, and is +completely transparent to programs using IMIO, it significantly increases +the power and flexibility of all programs which assess images, without +complicating the applications code. + +Examples ("map (image_name, ...)": + + image_name meaning + + image[*,-*] (flip columns end for end) + image[*,*,5] (band 5 of image cube) + image[*,5,*] (x,y --> x,z) + image[x1:x2,y1:y2] (2-D subraster) + image[x1:x2:n,*] (subsample by N in x) + +If the number of dimensions specified in the section is less than the number +of physical dimensions in the image then the higher dimensions default to 1. +If the number of dimensions given is greater than the number of phyiscal +dimensions then the nonphysical excess dimensions must be set to 1. +.endhelp ______________________________________________________________________ + + +procedure imisec (imdes, section) + +pointer imdes +char section[ARB] +int ip, i, dim, nsubscripts, nphysdim, nlogdim +long x1[IM_MAXDIM], x2[IM_MAXDIM], step[IM_MAXDIM], clktime() + +begin + # Set up null mapping (default). Check for null section string, + # or null section, and return if found. + + nphysdim = IM_NDIM(imdes) + + call aclrl (IM_VOFF(imdes,1), nphysdim) + call amovkl (long(1), IM_VSTEP(imdes,1), nphysdim) + + do dim = 1, nphysdim + IM_VMAP(imdes,dim) = dim + + if (section[1] == EOS) + return + else if (section[1] != '[') + call imerr (IM_NAME(imdes), SYS_IMSYNSEC) + + ip = 2 + while (IS_WHITE(section[ip])) + ip = ip + 1 + + if (section[ip] == ']') + return + + + # Decode the section string, yielding the vectors X1, X2, and STEP, + # of length NSUBSCRIPTS. + + for (i=1; i <= IM_MAXDIM && section[ip] != ']'; i=i+1) + call im_decode_subscript (section, ip, x1[i], x2[i], step[i]) + nsubscripts = i - 1 + + + # Set the transformation vectors. If too few dimensions were given + # set the higher dimensions to 1. If too many dimensions were given + # the higher dimensions must have been set to 1 in the section. + + for (dim = nsubscripts + 1; dim <= nphysdim; dim = dim + 1) { + x1[dim] = 1 + x2[dim] = 1 + step[dim] = 1 + } + for (dim = nphysdim + 1; dim <= nsubscripts; dim = dim + 1) + if (x1[dim] != 1 || x2[dim] != 1) + call imerr (IM_NAME(imdes), SYS_IMDIMSEC) + + nlogdim = 0 + for (dim=1; dim <= nphysdim; dim=dim+1) { + # Set up transformation for a single physical dimension. + call im_ctranset (imdes, dim, x1[dim], x2[dim], step[dim]) + + # Map logical dimension onto physical dimension. + if (x1[dim] != x2[dim]) { + nlogdim = nlogdim + 1 + IM_VMAP(imdes,nlogdim) = dim + IM_LEN(imdes,nlogdim) = IM_LEN(imdes,dim) + } + } + + # Convert a zero-dimensional image into a one dimensional image + # of length one pixel (section addresses a single pixel). + + if (nlogdim == 0) { + nlogdim = 1 + IM_VMAP(imdes,1) = 1 + IM_LEN(imdes,1) = 1 + } + + IM_NDIM(imdes) = nlogdim + IM_MTIME(imdes) = clktime (long(0)) +end + + +# IM_CTRANSET -- Set the logical to physical section coordinate transformation +# coefficients VOFF and VSTEP for the axis DIM. Adjust the length of the +# logical axis IM_LEN if needed. + +procedure im_ctranset (imdes, dim, x1_arg, x2_arg, step) + +pointer imdes +int dim +long x1_arg, x2_arg, step, x1, x2, length_axis + +begin + x1 = x1_arg + if (x1_arg == LAST) + x1 = IM_LEN(imdes,dim) + x2 = x2_arg + if (x2_arg == LAST) + x2 = IM_LEN(imdes,dim) + + # Compute the number of pixels in this axis of the section, allowing + # for non-unity step sizes. Set the axis length seen by the calling + # program to this value. + + length_axis = (x2 - x1) / step + 1 + if (length_axis <= 0) + call imerr (IM_NAME(imdes), SYS_IMSTEPSEC) + else + IM_LEN(imdes,dim) = length_axis + + IM_VOFF(imdes,dim) = x1 - step + IM_VSTEP(imdes,dim) = step +end + + +# IM_DECODE_SUBSCRIPT -- Decode a single subscript expression to produce the +# range of values for that subscript (X1:X2), and the sampling step size, STEP. +# Note that X1 may be less than, greater than, or equal to X2, and STEP may +# be a positive or negative nonzero integer. Various shorthand notations are +# permitted, as is embedded whitespace. + +procedure im_decode_subscript (section, ip, x1, x2, step) + +char section[ARB] +int ip +long x1, x2, step, temp +int ctol() +define synerr_ 99 + +begin + x1 = FIRST + x2 = LAST + step = 1 + + while (IS_WHITE(section[ip])) + ip = ip + 1 + + # Get X1, X2. + if (ctol (section, ip, temp) > 0) { # [x1 + x1 = temp + if (section[ip] == ':') { + ip = ip + 1 + if (ctol (section, ip, x2) == 0) # [x1:x2 + goto synerr_ + } else + x2 = x1 + + } else if (section[ip] == '-') { + x1 = LAST # [-* + x2 = FIRST + ip = ip + 1 + if (section[ip] == '*') + ip = ip + 1 + + } else if (section[ip] == '*') # [* + ip = ip + 1 + + while (IS_WHITE(section[ip])) + ip = ip + 1 + + # Get sample step size, if give. + if (section[ip] == ':') { # ..:step + ip = ip + 1 + if (ctol (section, ip, step) == 0) + goto synerr_ + else if (step == 0) + goto synerr_ + } + + # Allow notation such as "-*:5", (or even "-:5") where the step + # is obviously supposed to be negative. + + if (x1 > x2 && step > 0) + step = -step + + while (IS_WHITE(section[ip])) + ip = ip + 1 + + if (section[ip] == ',') { + ip = ip + 1 + return + } else if (section[ip] == ']') + return + +synerr_ + # Syntax error in image section specification. + call imerr (section, SYS_IMSYNSEC) +end diff --git a/sys/imio/imloop.x b/sys/imio/imloop.x new file mode 100644 index 00000000..ffae877b --- /dev/null +++ b/sys/imio/imloop.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imio.h> + +# IMLOOP -- Increment the vector V from VS to VE (nested do loops cannot +# be used because of the variable number of dimensions). Return LOOP_DONE +# when V exceeds VE. + +int procedure imloop (v, vs, ve, vinc, ndim) + +long v[ndim], vs[ndim], ve[ndim], vinc[ndim] +int ndim, dim + +begin + for (dim=2; dim <= ndim; dim=dim+1) { + v[dim] = v[dim] + vinc[dim] + + if ((vinc[dim] > 0 && v[dim] - ve[dim] > 0) || + (vinc[dim] < 0 && ve[dim] - v[dim] > 0)) { + + if (dim < ndim) + v[dim] = vs[dim] # advance to next dim + else + break + } else + return (LOOP_AGAIN) + } + + return (LOOP_DONE) +end diff --git a/sys/imio/immaky.x b/sys/imio/immaky.x new file mode 100644 index 00000000..186bfe5d --- /dev/null +++ b/sys/imio/immaky.x @@ -0,0 +1,90 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <error.h> +include <imhdr.h> +include <imio.h> + + +# IM_MAKE_NEWCOPY -- Copy the header of an existing, mapped image to +# initialize the header of a new image. Clear all fields that describe +# the pixels (a NEW_COPY image does not inherit any pixels). + +procedure im_make_newcopy (im, o_im) + +pointer im # new copy image +pointer o_im # image being copied + +pointer mw +int strlen() +long clktime() +pointer mw_open() +bool strne(), envgetb() +errchk imerr, realloc, mw_open, mw_loadim, mw_saveim, mw_close + +begin + if (strne (IM_MAGIC(o_im), "imhdr")) + call imerr (IM_NAME(im), SYS_IMMAGNCPY) + + # Copy the old image header (all fields, including user fields). + # Note that the incore version of the old header may be shorter than + # the actual header, in which case the user fields are currently + # not copied (would require reopening old header file). This is + # unlikely, however, since a very large in memory user area is + # allocated. + + # Update the value of HDRLEN for the input image in case the + # header has grown since the image was opened. + + IM_HDRLEN(o_im) = LEN_IMHDR + + (strlen(Memc[IM_USERAREA(o_im)])+1 + SZ_STRUCT-1) / SZ_STRUCT + + # Copy the header. + if (IM_LENHDRMEM(im) < IM_HDRLEN(o_im)) { + IM_LENHDRMEM(im) = IM_HDRLEN(o_im) + (SZ_UAPAD / SZ_STRUCT) + call realloc (im, IM_LENHDRMEM(im) + LEN_IMDES, TY_STRUCT) + } + call amovi (IM_MAGIC(o_im), IM_MAGIC(im), IM_HDRLEN(o_im) + 1) + + # If the old image was opened with an image section, modify the + # WCS of the new image accordingly. The section is applied to the + # MWCS Lterm automatically when the WCS is loaded from an image, + # so all we have to do is load the WCS of the old image section, + # and store it in the new image. + + if (IM_SECTUSED(o_im) == YES) + if (!envgetb ("nomwcs")) { + iferr (mw = mw_open (NULL, IM_NPHYSDIM(o_im))) + call erract (EA_WARN) + else { + call mw_loadim (mw, o_im) + call mw_saveim (mw, im) + call mw_close (mw) + } + } + + # If the pixels of the old image were stored in byte stream mode, + # make the new image that way too. Otherwise, the physical line + # length must be recomputed, as the new image may reside on a + # device with a different block size. + + if (IM_LEN(im,1) == IM_PHYSLEN(im,1)) + IM_VCOMPRESS(im) = YES + + IM_PIXOFF(im) = NULL + IM_HGMOFF(im) = NULL + IM_BLIST(im) = NULL + IM_SZBLIST(im) = 0 + IM_NBPIX(im) = 0 + IM_LIMTIME(im) = 0 + IM_OHDR(im) = o_im + IM_PIXFILE(im) = EOS + + IM_CTIME(im) = clktime (long(0)) + IM_MTIME(im) = IM_CTIME(im) + + # Add a line to the history file (inherited from old image). + call strcat ("New copy of ", IM_HISTORY(im), SZ_IMHIST) + call strcat (IM_NAME(o_im), IM_HISTORY(im), SZ_IMHIST) + call strcat ("\n", IM_HISTORY(im), SZ_IMHIST) +end diff --git a/sys/imio/immap.x b/sys/imio/immap.x new file mode 100644 index 00000000..dc1a98ee --- /dev/null +++ b/sys/imio/immap.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMMAP -- Map an imagefile to an image structure. This is the "open" +# procedure for an imagefile. + +pointer procedure immap (imspec, acmode, hdr_arg) + +char imspec[ARB] #I image specification +int acmode #I image access mode +int hdr_arg #I length of user fields, or header pointer + +pointer immapz() +errchk iki_init + +begin + call iki_init() + return (immapz (imspec, acmode, hdr_arg)) +end diff --git a/sys/imio/immapz.x b/sys/imio/immapz.x new file mode 100644 index 00000000..71e03c8c --- /dev/null +++ b/sys/imio/immapz.x @@ -0,0 +1,189 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <error.h> +include <mach.h> +include <imhdr.h> +include <imio.h> + +# IMMAPZ -- Map an imagefile to an image structure. This is the IMIO internal +# version of the immap procedure, called once the IKI has been initialized. + +pointer procedure immapz (imspec, acmode, hdr_arg) + +char imspec[ARB] # image specification +int acmode # image access mode +int hdr_arg # length of user fields, or header pointer + +pointer sp, imname, root, cluster, ksection, section, im +char inname[SZ_PATHNAME] +int min_lenuserarea, len_imhdr, cl_index, cl_size, i, val +int btoi(), ctoi(), envfind(), fnroot(), strlen(), envgeti(), strncmp() +errchk im_make_newcopy, im_init_newimage, malloc + +begin + call smark (sp) + call salloc (imname, SZ_PATHNAME, TY_CHAR) + call salloc (cluster, SZ_PATHNAME, TY_CHAR) + call salloc (ksection, SZ_FNAME, TY_CHAR) + call salloc (section, SZ_FNAME, TY_CHAR) + call salloc (root, SZ_FNAME, TY_CHAR) + + # The user or system manager can specify the minimum user area size + # as an environment variable, if the IRAF default is too small. + + if (envfind ("min_lenuserarea", Memc[section], SZ_FNAME) > 0) { + i = 1 + if (ctoi (Memc[section], i, min_lenuserarea) <= 0) + min_lenuserarea = MIN_LENUSERAREA + } else + min_lenuserarea = MIN_LENUSERAREA + + + # If we're given a URL to an image, cache the file. + if (strncmp ("http://", imspec, 7) == 0) + call fcadd ("cache$", imspec, "", inname, SZ_PATHNAME) + else if (strncmp ("file:///localhost", imspec, 17) == 0) + call strcpy (imspec[18], inname, SZ_PATHNAME) + else if (strncmp ("file://localhost", imspec, 16) == 0) + call strcpy (imspec[17], inname, SZ_PATHNAME) + else if (strncmp ("file://", imspec, 7) == 0) + call strcpy (imspec[7], inname, SZ_PATHNAME) + else + call strcpy (imspec, inname, SZ_PATHNAME) + + + # Parse the full image specification into its component parts. + call imparse (inname, Memc[cluster],SZ_PATHNAME, + Memc[ksection],SZ_FNAME, Memc[section],SZ_FNAME, cl_index,cl_size) + + # Allocate buffer for image descriptor/image header. Note the dual + # use of the HDR_ARG argument. In the case of a new copy image, + # hdr_arg is a pointer to the image to be copied; otherwise is is the + # length of the user area in CHARS (since the user area is a string + # buffer). + + if (acmode == NEW_COPY) { + len_imhdr = max (LEN_IMHDR + min_lenuserarea / SZ_STRUCT, + IM_HDRLEN(hdr_arg) + SZ_UAPAD / SZ_STRUCT) + } else { + len_imhdr = LEN_IMHDR + + max (min_lenuserarea, int(hdr_arg)) / SZ_STRUCT + } + + call malloc (im, LEN_IMDES + len_imhdr, TY_STRUCT) + call aclri (Memi[im], LEN_IMDES + min (len_imhdr, LEN_IMHDR + 1)) + IM_LENHDRMEM(im) = len_imhdr + + # Initialize the image descriptor structure. + IM_ACMODE(im) = acmode + IM_PFD(im) = NULL + IM_HDRLEN(im) = len_imhdr + IM_UPDATE(im) = btoi (acmode != READ_ONLY) + IM_UABLOCKED(im) = -1 + + # Initialize options. + IM_VNBUFS(im) = 1 + IM_VCOMPRESS(im) = DEF_COMPRESS + IM_VADVICE(im) = DEF_ADVICE + + # Initialize the IMIO buffer size defaults. The builtin defaults + # are used unless a value is explicitly set in the environment; + # an IMSET on the open descriptor will override either. + + IM_VBUFSIZE(im) = DEF_FIOBUFSIZE + ifnoerr (val = envgeti (ENV_BUFSIZE)) + IM_VBUFSIZE(im) = val / SZB_CHAR + IM_VBUFFRAC(im) = DEF_FIOBUFFRAC + ifnoerr (val = envgeti (ENV_BUFFRAC)) + IM_VBUFFRAC(im) = val + IM_VBUFMAX(im) = DEF_MAXFIOBUFSIZE + ifnoerr (val = envgeti (ENV_BUFMAX)) + IM_VBUFMAX(im) = val + + # Set fast i/o flag to yes initially to force IMOPSF and hence IMSETBUF + # to be called when the first i/o operation occurs. + + IM_FAST(im) = YES +IM_FAST(im) = NO + + # Set the image name field, used by IMERR everywhere. + call strcpy (inname, IM_NAME(im), SZ_IMNAME) + + # Initialize the mode dependent fields of the image header. + if (acmode == NEW_COPY) + call im_make_newcopy (im, hdr_arg) + else if (acmode == NEW_IMAGE) + call im_init_newimage (im, IM_HDRLEN(im)) + + # Set the following in case it isn't set by the kernel. + call strcpy ("imhdr", IM_MAGIC(im), SZ_IMMAGIC) + + # Physically open the image and read the header. Note that IKI_OPEN + # may realloc the image descriptor if additional space is required, + # hence the pointer IM may be modified. + + iferr { + call iki_open (im, Memc[cluster], Memc[ksection], + cl_index, cl_size, acmode, hdr_arg) + } then { + call mfree (im, TY_STRUCT) + call erract (EA_ERROR) + } + + # Format a full image name specification if we have a cl_index format + # image. IM_NAME is used mainly as an image identifier in error + # messages, so truncate the string by omitting some of the leading + # pathname information if the resultant string would be excessively + # long. + + if (IM_CLSIZE(im) > 1) { + call sprintf (Memc[imname], SZ_PATHNAME, "%s[%d/%d]%s%s") + call pargstr (Memc[cluster]) + call pargi (IM_CLINDEX(im)) + call pargi (IM_CLSIZE(im)) + call pargstr (Memc[ksection]) + call pargstr (Memc[section]) + + if (strlen (Memc[imname]) > SZ_IMNAME) { + i = fnroot (Memc[cluster], Memc[root], SZ_FNAME) + call sprintf (Memc[imname], SZ_PATHNAME, "%s[%d/%d]%s%s") + call pargstr (Memc[root]) + call pargi (IM_CLINDEX(im)) + call pargi (IM_CLSIZE(im)) + call pargstr (Memc[ksection]) + call pargstr (Memc[section]) + } + + call strcpy (Memc[imname], IM_NAME(im), SZ_IMNAME) + } + + # Save those image header fields that get modified if an image section + # is specified. + + IM_NPHYSDIM(im) = IM_NDIM(im) + IM_SVMTIME(im) = IM_MTIME(im) + call amovl (IM_LEN(im,1), IM_SVLEN(im,1), IM_MAXDIM) + + # Process the image section if one was given, i.e., parse the section + # string and set up a transformation to be applied to logical input + # vectors. + + if (Memc[section] != EOS) { + if (acmode == NEW_COPY || acmode == NEW_IMAGE) { + call iki_close (im) + call mfree (im, TY_STRUCT) + call imerr (IM_NAME(im), SYS_IMSECTNEWIM) + } + call imisec (im, Memc[section]) + IM_SECTUSED(im) = YES + } else { + # IM_VOFF is already zero, because of the CALLOC. + call amovkl (long(1), IM_VSTEP(im,1), IM_MAXDIM) + do i = 1, IM_MAXDIM + IM_VMAP(im,i) = i + } + + call sfree (sp) + return (im) +end diff --git a/sys/imio/imnote.x b/sys/imio/imnote.x new file mode 100644 index 00000000..09547043 --- /dev/null +++ b/sys/imio/imnote.x @@ -0,0 +1,30 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> + +# IMNOTE -- Given the coordinates of a pixel, return the character offset +# of that pixel in the pixel storage file. + +long procedure imnote (im, v) + +pointer im # image descriptor +long v[IM_MAXDIM] # physical coords of pixel + +int sz_pixel, i +long pixel_index, dim_offset, char_offset0 +include <szpixtype.inc> + +begin + sz_pixel = pix_size[IM_PIXTYPE(im)] + pixel_index = v[1] + dim_offset = 1 + + do i = 2, IM_NPHYSDIM(im) { + dim_offset = dim_offset * IM_PHYSLEN(im,i-1) + pixel_index = pixel_index + dim_offset * (v[i] - 1) + } + + char_offset0 = (pixel_index-1) * sz_pixel + return (IM_PIXOFF(im) + char_offset0) +end diff --git a/sys/imio/imopsf.x b/sys/imio/imopsf.x new file mode 100644 index 00000000..f790481a --- /dev/null +++ b/sys/imio/imopsf.x @@ -0,0 +1,140 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <pmset.h> +include <plset.h> +include <imhdr.h> +include <imio.h> +include <fset.h> + +# IMOPSF -- Open (or create) the pixel storage file. If the file has already +# been opened do nothing but set the buffer size. Until the pixel storage +# file has been opened we do not know the device block size, image line length, +# or whether IM_FAST type i/o is possible. + +procedure imopsf (im) + +pointer im + +pointer sp, imname, ref_im, pfd +int sv_acmode, sv_update, ndim, depth, i +errchk iki_opix, open +int open() + +begin + call smark (sp) + call salloc (imname, SZ_IMNAME, TY_CHAR) + + if (IM_PL(im) != NULL) { + if (IM_PFD(im) == NULL) { + # Complete the initialization of a mask image. + ref_im = IM_PLREFIM(im) + + sv_acmode = IM_ACMODE(im) + sv_update = IM_UPDATE(im) + call strcpy (IM_NAME(im), Memc[imname], SZ_IMNAME) + + if (ref_im != NULL) { + # Create a mask the same size as the physical size of the + # reference image. Inherit any image section from the + # reference image. + + IM_NDIM(im) = IM_NDIM(ref_im) + IM_NPHYSDIM(im) = IM_NPHYSDIM(ref_im) + IM_SECTUSED(im) = IM_SECTUSED(ref_im) + call amovl (IM_LEN(ref_im,1), IM_LEN(im,1), IM_MAXDIM) + call amovl (IM_PHYSLEN(ref_im,1),IM_PHYSLEN(im,1),IM_MAXDIM) + call amovl (IM_SVLEN(ref_im,1), IM_SVLEN(im,1), IM_MAXDIM) + call amovl (IM_VMAP(ref_im,1), IM_VMAP(im,1), IM_MAXDIM) + call amovl (IM_VOFF(ref_im,1), IM_VOFF(im,1), IM_MAXDIM) + call amovl (IM_VSTEP(ref_im,1), IM_VSTEP(im,1), IM_MAXDIM) + + # Tell PMIO to use this image as the reference image. + call pm_seti (IM_PL(im), P_REFIM, im) + + } else if (sv_acmode == NEW_IMAGE || sv_acmode == NEW_COPY) { + # If ndim was not explicitly set, compute it by counting + # the number of nonzero dimensions. + + ndim = IM_NDIM(im) + if (ndim == 0) { + ndim = 1 + while (IM_LEN(im,ndim) > 0 && ndim <= IM_MAXDIM) + ndim = ndim + 1 + ndim = ndim - 1 + IM_NDIM(im) = ndim + } + + # Make sure dimension stuff makes sense. + if (ndim < 0 || ndim > IM_MAXDIM) + call imerr (IM_NAME(im), SYS_IMNDIM) + + do i = 1, ndim + if (IM_LEN(im,i) <= 0) + call imerr (IM_NAME(im), SYS_IMDIMLEN) + + # Set the unused higher dimensions to 1. This makes it + # possible to access the image as if it were higher + # dimensional, and in a way it truely is. + + do i = ndim + 1, IM_MAXDIM + IM_LEN(im,i) = 1 + + IM_NPHYSDIM(im) = ndim + call amovl (IM_LEN(im,1), IM_PHYSLEN(im,1), IM_MAXDIM) + call amovl (IM_LEN(im,1), IM_SVLEN(im,1), IM_MAXDIM) + + # Initialize the empty mask to the newly determined size. + depth = PL_MAXDEPTH + if (and (IM_PLFLAGS(im), PL_BOOL) != 0) + depth = 1 + call pl_ssize (IM_PL(im), IM_NDIM(im), IM_LEN(im,1), depth) + } + + call strcpy (Memc[imname], IM_NAME(im), SZ_IMNAME) + IM_ACMODE(im) = sv_acmode + IM_UPDATE(im) = sv_update + IM_PIXOFF(im) = 1 + IM_HGMOFF(im) = NULL + IM_BLIST(im) = NULL + IM_HFD(im) = NULL + + # Do the following in two statements so that IM_PFD does + # not get set if the OPEN fails and does an error exit. + + pfd = open ("dev$null", READ_WRITE, BINARY_FILE) + IM_PFD(im) = pfd + } + + # Execute this even if pixel file has already been opened. + call imsetbuf (IM_PFD(im), im) + + # "Fast i/o" in the conventional sense no IMIO buffering) + # is not permitted for mask images, since IMIO must buffer + # the pixels, which are generated at run time. + + if (IM_FAST(im) == YES) { + IM_PLFLAGS(im) = or (IM_PLFLAGS(im), PL_FAST) + IM_FAST(im) = NO + } + + } else { + # Open the pixel file for a regular image. + if (IM_PFD(im) == NULL) + call iki_opix (im) + + # Execute this even if pixel file has already been opened. + call imsetbuf (IM_PFD(im), im) + + # If F_CLOSEFD is set on the pixel file, the host channel to the + # file will be physically closed off except when an i/o operation + # is in progress (used to conserve host file descriptors) in + # applications which must open a large number of images all at + # once). + + if (IM_VCLOSEFD(im) == YES) + call fseti (IM_PFD(im), F_CLOSEFD, YES) + } + + call sfree (sp) +end diff --git a/sys/imio/impak.gx b/sys/imio/impak.gx new file mode 100644 index 00000000..feb37f2c --- /dev/null +++ b/sys/imio/impak.gx @@ -0,0 +1,46 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMPAK? -- Convert an array of pixels of a specific datatype to the +# datatype given as the final argument. + +procedure impak$t (a, b, npix, dtype) + +PIXEL a[npix] +int b[npix], npix, dtype + +pointer bp + +begin + switch (dtype) { + case TY_USHORT: + call acht$tu (a, b, npix) + case TY_SHORT: + call acht$ts (a, b, npix) + case TY_INT: + if (SZ_INT == SZ_INT32) + call acht$ti (a, b, npix) + else { + call malloc (bp, npix, TY_INT) + call acht$ti (a, Memi[bp], npix) + call ipak32 (Memi[bp], b, npix) + call mfree (bp, TY_INT) + } + case TY_LONG: + if (SZ_INT == SZ_INT32) + call acht$tl (a, b, npix) + else { + call malloc (bp, npix, TY_LONG) + call acht$tl (a, Meml[bp], npix) + call ipak32 (Meml[bp], b, npix) + call mfree (bp, TY_LONG) + } + case TY_REAL: + call acht$tr (a, b, npix) + case TY_DOUBLE: + call acht$td (a, b, npix) + case TY_COMPLEX: + call acht$tx (a, b, npix) + default: + call error (1, "Unknown datatype in imagefile") + } +end diff --git a/sys/imio/imparse.x b/sys/imio/imparse.x new file mode 100644 index 00000000..cc98070d --- /dev/null +++ b/sys/imio/imparse.x @@ -0,0 +1,155 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <ctype.h> + +# IMPARSE -- Parse an image specification into the cluster name, cluster index, +# cluster size, kernel section, and image section fields. +# +# Syntax: cluster[cl_index/cl_size][ksection][section] +# +# where all fields are optional except the cluster name. In the limiting case +# (cl_size = 1) the cluster name and image name are the same. CL_INDEX and +# CL_SIZE must be simple nonnegative decimal integer constants, if given. The +# [ character must be escaped to be included in the filename of the cluster. +# +# NOTE -- The image specification syntax is not frozen and further changes +# are likely. Use of this routine outside IMIO is not recommended as the +# calling sequence may change. Use imgname and imgsection instead. + +procedure imparse (imspec, cluster, sz_cluster, ksection, sz_ksection, + section, sz_section, cl_index, cl_size) + +char imspec[ARB] # full image specification +char cluster[ARB] # receives cluster name +int sz_cluster # max chars in cluster name +char ksection[ARB] # receives kernel section +int sz_ksection # max chars in kernel section name +char section[ARB] # receives image section +int sz_section # max chars in image section name +int cl_index # receives cluster index (default -1) +int cl_size # receives cluster size (default -1) + +pointer sp, cp, secbuf +int ip, op, lbrack, level, ch, n +bool is_ksection, sect_out, ksect_out +int stridx() +errchk syserrs + +begin + call smark (sp) + call salloc (secbuf, SZ_LINE, TY_CHAR) + + ip = 1 + op = 1 + + # Extract cluster name. The first (unescaped) [ marks the start of + # either the cl_index subscript or a section field. + + for (ch=imspec[ip]; ch != EOS && ch != '['; ch=imspec[ip]) { + if (ch == '\\' && imspec[ip+1] == '[') { + cluster[op] = '\\' + op = op + 1 + cluster[op] = '[' + ip = ip + 1 + } else + cluster[op] = ch + + op = min (sz_cluster, op + 1) + ip = ip + 1 + } + + cluster[op] = EOS + ksection[1] = EOS + section[1] = EOS + lbrack = ip + cl_index = -1 + cl_size = -1 + + if (ch == EOS) { + call sfree (sp) + return + } + + # If we have a [...] field, determine whether it is a cl_index + # subscript or a kernel or image section. A cl_index subscript is + # anything with the syntax [ddd] or [ddd/ddd]; anything else is a + # kernel or image section. + + ip = ip + 1 + n = -1 + + for (ch=imspec[ip]; ch != EOS; ch=imspec[ip]) { + if (IS_DIGIT(ch)) { + if (n < 0) + n = 0 + n = (n * 10) + TO_INTEG(ch) + } else if (ch == '/') { + cl_index = max (n, 1) + n = -1 + } else if (ch == ']') { + ip = ip + 1 + break + } else { + # Not a cl_index subscript; must be a section. + ip = lbrack + n = -1 + break + } + ip = ip + 1 + } + + if (cl_index < 0) + cl_index = n + else + cl_size = n + + # The rest of the input string consists of the kernel and image + # sections, if any. + + sect_out = false + ksect_out = false + + while (imspec[ip] == '[') { + is_ksection = false + cp = secbuf + level = 0 + + for (ch=imspec[ip]; ch != EOS; ch=imspec[ip]) { + if (ch == '[') + level = level + 1 + else if (ch == ']') + level = level - 1 + else if (!is_ksection) + if (stridx (imspec[ip], " 0123456789+-:*,") == 0) + is_ksection = true + + Memc[cp] = ch + cp = cp + 1 + ip = ip + 1 + + if (level == 0) + break + } + Memc[cp] = EOS + + if (level != 0) + call syserrs (SYS_IMSYNSEC, imspec) + if (is_ksection) { + if (ksect_out) + call syserrs (SYS_IMSYNSEC, imspec) + call strcpy (Memc[secbuf], ksection, sz_ksection) + ksect_out = true + } else { + if (sect_out) + call syserrs (SYS_IMSYNSEC, imspec) + call strcpy (Memc[secbuf], section, sz_section) + sect_out = true + } + + while (imspec[ip] != EOS && imspec[ip] != '[') + ip = ip + 1 + } + + call sfree (sp) +end diff --git a/sys/imio/impgs.gx b/sys/imio/impgs.gx new file mode 100644 index 00000000..1aa0f432 --- /dev/null +++ b/sys/imio/impgs.gx @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> + +# IMPGS? -- Put a general section of a specific datatype. + +pointer procedure impgs$t (imdes, vs, ve, ndim) + +pointer imdes +long vs[IM_MAXDIM], ve[IM_MAXDIM] +pointer bp, imgobf() +int ndim +extern imfls$t() +errchk imflush, imgobf + +begin + # Flush the output buffer, if appropriate. IMFLUSH calls + # one of the IMFLS? routines, which write out the section. + + if (IM_FLUSH(imdes) == YES) + call zcall1 (IM_FLUSHEPA(imdes), imdes) + + # Get an (output) buffer to put the pixels into. Save the + # section parameters in the image descriptor. Save the epa + # of the typed flush procedure in the image descriptor. + + bp = imgobf (imdes, vs, ve, ndim, TY_PIXEL) + call zlocpr (imfls$t, IM_FLUSHEPA(imdes)) + IM_FLUSH(imdes) = YES + + return (bp) +end diff --git a/sys/imio/impl1.gx b/sys/imio/impl1.gx new file mode 100644 index 00000000..4fe23b4b --- /dev/null +++ b/sys/imio/impl1.gx @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> + +# IMPL1? -- Put a line to an apparently one dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure impl1$t (im) + +pointer im # image header pointer +int fd, nchars +long offset +pointer bp, impgs$t(), fwritep() +errchk imopsf + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_PIXEL) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + offset = IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_PIXEL + ifnoerr (bp = (fwritep (fd, offset, nchars) - 1) / SZ_PIXEL + 1) + return (bp) + } + return (impgs$t (im, long(1), IM_LEN(im,1), 1)) + } +end diff --git a/sys/imio/impl2.gx b/sys/imio/impl2.gx new file mode 100644 index 00000000..545d2ed3 --- /dev/null +++ b/sys/imio/impl2.gx @@ -0,0 +1,47 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include <imio.h> + +# IMPL2? -- Put a line to an apparently two dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure impl2$t (im, linenum) + +pointer im # image header pointer +int linenum # line to be written + +int fd, nchars +long vs[2], ve[2], offset +pointer bp, impgs$t(), fwritep() +errchk imopsf, imerr + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_PIXEL) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + if (linenum < 1 || linenum > IM_LEN(im,2)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + offset = (linenum - 1) * IM_PHYSLEN(im,1) * SZ_PIXEL + + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_PIXEL + ifnoerr (bp = (fwritep (fd, offset, nchars) - 1) / SZ_PIXEL + 1) + return (bp) + } + + vs[1] = 1 + ve[1] = IM_LEN(im,1) + vs[2] = linenum + ve[2] = linenum + + return (impgs$t (im, vs, ve, 2)) + } +end diff --git a/sys/imio/impl3.gx b/sys/imio/impl3.gx new file mode 100644 index 00000000..d9ed5699 --- /dev/null +++ b/sys/imio/impl3.gx @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include <imio.h> + +# IMPL3? -- Put a line to an apparently three dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure impl3$t (im, line, band) + +pointer im # image header pointer +int line # line number within band +int band # band number + +int fd, nchars +long vs[3], ve[3], offset +pointer bp, impgs$t(), fwritep() +errchk imopsf, imerr + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_PIXEL) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + if (line < 1 || line > IM_LEN(im,2) || + band < 1 || band > IM_LEN(im,3)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + offset = (((band - 1) * IM_PHYSLEN(im,2) + line - 1) * + IM_PHYSLEN(im,1)) * SZ_PIXEL + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_PIXEL + ifnoerr (bp = (fwritep (fd, offset, nchars) - 1) / SZ_PIXEL + 1) + return (bp) + } + + vs[1] = 1 + ve[1] = IM_LEN(im,1) + vs[2] = line + ve[2] = line + vs[3] = band + ve[3] = band + + return (impgs$t (im, vs, ve, 3)) + } +end diff --git a/sys/imio/impmhdr.x b/sys/imio/impmhdr.x new file mode 100644 index 00000000..d8219996 --- /dev/null +++ b/sys/imio/impmhdr.x @@ -0,0 +1,331 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> +include <ctype.h> + +.help impmhdr +.nf -------------------------------------------------------------------------- +IMPMHDR -- Routines to encode/decode an image header in a title string +such as is provided by pl_[save|load]f, so that general image headers can +be saved in .pl files. + + nchars = im_pmsvhdr (im, bufp, sz_buf) + im_pmldhdr (im, bufp) + +The information saved in the plio save file title string consist of a +series of keyword = value assignments, one per line. +.endhelp --------------------------------------------------------------------- + +define DEF_SZBUF 32768 +define INC_SZBUF 16384 +define INC_HDRMEM 8100 +define IDB_RECLEN 80 + +define KW_TITLE "$TITLE = " +define LEN_KWTITLE 9 +define KW_CTIME "$CTIME = " +define LEN_KWCTIME 9 +define KW_MTIME "$MTIME = " +define LEN_KWMTIME 9 +define KW_LIMTIME "$LIMTIME = " +define LEN_KWLIMTIME 11 +define KW_MINPIXVAL "$MINPIXVAL = " +define LEN_KWMINPIXVAL 13 +define KW_MAXPIXVAL "$MAXPIXVAL = " +define LEN_KWMAXPIXVAL 13 + + +# IM_PMSVHDR -- Save an image header in a text string as a sequence of +# keyword = value assignments, one per line. A pointer to a text buffer +# containing the encoded header is returned as the output parameter, and +# the string length in chars is returned as the function value. +# The caller should deallocate this buffer when it is no longer needed. + +int procedure im_pmsvhdr (im, bp, sz_buf) + +pointer im #I image descriptor +pointer bp #U buffer containing encoded header +int sz_buf #U allocated size of buffer, chars + +int nchars, ualen, ch, i +pointer sp, tbuf, ip, op, idb, rp +errchk malloc, realloc, idb_open +int gstrcpy(), idb_nextcard +pointer idb_open() + +begin + call smark (sp) + call salloc (tbuf, SZ_IMTITLE, TY_CHAR) + + # Allocate text buffer if the user hasn't already done so. + if (bp == NULL || sz_buf <= 0) { + sz_buf = DEF_SZBUF + call malloc (bp, sz_buf, TY_CHAR) + } + + # Store title string in buffer. + call strcpy (IM_TITLE(im), Memc[tbuf], SZ_IMTITLE) + op = bp + gstrcpy (KW_TITLE, Memc[bp], ARB) + Memc[op] = '"'; op = op + 1 + for (ip=tbuf; Memc[ip] != EOS; ip=ip+1) { + if (Memc[ip] == '"') { + Memc[op] = '\\'; op = op + 1 + } + Memc[op] = Memc[ip]; op = op + 1 + } + Memc[op] = '"'; op = op + 1 + Memc[op] = '\n'; op = op + 1 + + # Store the create time in buffer. + call sprintf (Memc[tbuf], SZ_IMTITLE, "%d") + call pargl (IM_CTIME(im)) + op = op + gstrcpy (KW_CTIME, Memc[op], ARB) + op = op + gstrcpy (Memc[tbuf], Memc[op], ARB) + Memc[op] = '\n'; op = op + 1 + + # Store the modify time in buffer. + call sprintf (Memc[tbuf], SZ_IMTITLE, "%d") + call pargl (IM_MTIME(im)) + op = op + gstrcpy (KW_MTIME, Memc[op], ARB) + op = op + gstrcpy (Memc[tbuf], Memc[op], ARB) + Memc[op] = '\n'; op = op + 1 + + # Store the limits time in buffer. + call sprintf (Memc[tbuf], SZ_IMTITLE, "%d") + call pargl (IM_LIMTIME(im)) + op = op + gstrcpy (KW_LIMTIME, Memc[op], ARB) + op = op + gstrcpy (Memc[tbuf], Memc[op], ARB) + Memc[op] = '\n'; op = op + 1 + + # Store the minimum good pixel value in buffer. + call sprintf (Memc[tbuf], SZ_IMTITLE, "%g") + call pargr (IM_MIN(im)) + op = op + gstrcpy (KW_MINPIXVAL, Memc[op], ARB) + op = op + gstrcpy (Memc[tbuf], Memc[op], ARB) + Memc[op] = '\n'; op = op + 1 + + # Store the maximum good pixel value in buffer. + call sprintf (Memc[tbuf], SZ_IMTITLE, "%g") + call pargr (IM_MAX(im)) + op = op + gstrcpy (KW_MAXPIXVAL, Memc[op], ARB) + op = op + gstrcpy (Memc[tbuf], Memc[op], ARB) + Memc[op] = '\n'; op = op + 1 + + # Copy the header cards. + idb = idb_open (im, ualen) + while (idb_nextcard (idb, rp) != EOF) { + + # Increase the size of the output buffer if it fills. + nchars = op - bp + if (sz_buf - nchars < IDB_RECLEN) { + sz_buf = sz_buf + INC_SZBUF + call realloc (bp, sz_buf, TY_CHAR) + op = bp + nchars + } + + # Copy the card, stripping any trailing whitespace. + nchars = 0 + do i = 1, IDB_RECLEN { + ch = Memc[rp+i-1] + Memc[op+i-1] = ch + if (!IS_WHITE(ch)) + nchars = i + } + + op = op + nchars + Memc[op] = '\n'; op = op + 1 + } + + # All done, terminate the string and return any extra space. + Memc[op] = EOS; op = op + 1 + nchars = op - bp + call realloc (bp, nchars, TY_CHAR) + + # Clean up. + call idb_close (idb) + call sfree (sp) + + return (nchars) +end + + +# IM_PMLDHDR -- Load the image header from a save buffer, prepared in a +# previous call to im_pmsvhdr. The saved header will overwrite any +# existing cards in the output image header. + +procedure im_pmldhdr (im, bp) + +pointer im #I image descriptor +pointer bp #I pointer to text buffer (header save buf) + +int hdrlen, sz_ua, nchars, ch, i +pointer sp, tbuf, ip, op, rp, ua +int strncmp(), ctol(), ctor() +errchk realloc + +begin + call smark (sp) + call salloc (tbuf, SZ_IMTITLE, TY_CHAR) + + # Get the image title string. + for (ip = bp; Memc[ip] != EOS;) { + if (Memc[ip] == '$') { + if (strncmp (Memc[ip], KW_TITLE, LEN_KWTITLE) == 0) { + # Advance to first character of quoted string. + ip = ip + LEN_KWTITLE + while (Memc[ip] != EOS && Memc[ip] != '"') + ip = ip + 1 + if (Memc[ip] == '"') + ip = ip + 1 + + # Extract the string. + op = tbuf + while (Memc[ip] != EOS && Memc[ip] != '"') { + if (Memc[ip] == '\\' && Memc[ip+1] == '"') + ip = ip + 1 + Memc[op] = Memc[ip] + op = min (tbuf + SZ_IMTITLE, op + 1) + ip = ip + 1 + } + + # Store in image descriptor. + Memc[op] = EOS + call strcpy (Memc[tbuf], IM_TITLE(im), SZ_IMTITLE) + + # Advance to next line. + while (Memc[ip] != EOS && Memc[ip] != '\n') + ip = ip + 1 + if (Memc[ip] == '\n') + ip = ip + 1 + + } else if (strncmp (Memc[ip], KW_CTIME, LEN_KWCTIME) == 0) { + # Decode the create time. + ip = ip + LEN_KWCTIME + rp = 1 + if (ctol (Memc[ip], rp, IM_CTIME(im)) <= 0) + IM_CTIME(im) = 0 + ip = ip + rp - 1 + + # Advance to next line. + while (Memc[ip] != EOS && Memc[ip] != '\n') + ip = ip + 1 + if (Memc[ip] == '\n') + ip = ip + 1 + + } else if (strncmp (Memc[ip], KW_MTIME, LEN_KWMTIME) == 0) { + # Decode the modify time. + ip = ip + LEN_KWMTIME + rp = 1 + if (ctol (Memc[ip], rp, IM_MTIME(im)) <= 0) + IM_MTIME(im) = 0 + ip = ip + rp - 1 + + # Advance to next line. + while (Memc[ip] != EOS && Memc[ip] != '\n') + ip = ip + 1 + if (Memc[ip] == '\n') + ip = ip + 1 + + } else if (strncmp (Memc[ip], KW_LIMTIME, LEN_KWLIMTIME) == 0) { + # Decode the limits time. + ip = ip + LEN_KWLIMTIME + rp = 1 + if (ctol (Memc[ip], rp, IM_LIMTIME(im)) <= 0) + IM_LIMTIME(im) = 0 + ip = ip + rp - 1 + + # Advance to next line. + while (Memc[ip] != EOS && Memc[ip] != '\n') + ip = ip + 1 + if (Memc[ip] == '\n') + ip = ip + 1 + + } else if (strncmp(Memc[ip],KW_MINPIXVAL,LEN_KWMINPIXVAL)==0) { + # Decode the minimum pixel value. + ip = ip + LEN_KWMINPIXVAL + rp = 1 + if (ctor (Memc[ip], rp, IM_MIN(im)) <= 0) + IM_MIN(im) = 0.0 + ip = ip + rp - 1 + + # Advance to next line. + while (Memc[ip] != EOS && Memc[ip] != '\n') + ip = ip + 1 + if (Memc[ip] == '\n') + ip = ip + 1 + + } else if (strncmp(Memc[ip],KW_MAXPIXVAL,LEN_KWMAXPIXVAL)==0) { + # Decode the maximum pixel value. + ip = ip + LEN_KWMAXPIXVAL + rp = 1 + if (ctor (Memc[ip], rp, IM_MAX(im)) <= 0) + IM_MAX(im) = 0.0 + ip = ip + rp - 1 + + # Advance to next line. + while (Memc[ip] != EOS && Memc[ip] != '\n') + ip = ip + 1 + if (Memc[ip] == '\n') + ip = ip + 1 + + } else { + # No keyword matched. Advance to next line. + while (Memc[ip] != EOS && Memc[ip] != '\n') + ip = ip + 1 + if (Memc[ip] == '\n') + ip = ip + 1 + } + } else + break + } + + # Get the header keywords. + hdrlen = LEN_IMDES + IM_LENHDRMEM(im) + sz_ua = (hdrlen - IMU) * SZ_STRUCT - 1 + ua = IM_USERAREA(im) + op = ua + + while (Memc[ip] != EOS) { + rp = op + + # Reallocate descriptor if we need more space. Since we are + # called at image map time and the descriptor pointer has not + # yet been passed out, the image descriptor can be reallocated. + + nchars = rp - ua + if (nchars + IDB_RECLEN + 2 > sz_ua) { + hdrlen = hdrlen + INC_HDRMEM + IM_LENHDRMEM(im) = IM_LENHDRMEM(im) + INC_HDRMEM + call realloc (im, hdrlen, TY_STRUCT) + sz_ua = (hdrlen - IMU) * SZ_STRUCT - 1 + ua = IM_USERAREA(im) + op = ua + nchars + } + + # Copy the saved card, leave IP positioned to past newline. + do i = 1, IDB_RECLEN + 1 { + ch = Memc[ip] + if (ch != EOS) + ip = ip + 1 + if (ch == '\n') + break + Memc[op] = ch + op = op + 1 + } + + # Blank fill the card. + while (op - rp < IDB_RECLEN) { + Memc[op] = ' ' + op = op + 1 + } + + # Add newline termination. + Memc[op] = '\n'; op = op + 1 + } + + Memc[op] = EOS + IM_UABLOCKED(im) = YES + + call sfree (sp) +end diff --git a/sys/imio/impmlne1.x b/sys/imio/impmlne1.x new file mode 100644 index 00000000..e8348349 --- /dev/null +++ b/sys/imio/impmlne1.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> + +# IM_PMLNE1 -- Pixel mask line not empty. + +bool procedure im_pmlne1 (im) + +pointer im #I image descriptor +long v[IM_MAXDIM] + +bool pm_linenotempty() + +begin + call amovkl (1, v, IM_MAXDIM) + return (pm_linenotempty (IM_PL(im), v)) +end diff --git a/sys/imio/impmlne2.x b/sys/imio/impmlne2.x new file mode 100644 index 00000000..6f15dfd1 --- /dev/null +++ b/sys/imio/impmlne2.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> + +# IM_PMLNE2 -- Pixel mask line not empty. + +bool procedure im_pmlne2 (im, lineno) + +pointer im #I image descriptor +int lineno #I line number + +long v[IM_MAXDIM] +bool pm_linenotempty() + +begin + call amovkl (1, v, IM_MAXDIM) + v[2] = lineno + + return (pm_linenotempty (IM_PL(im), v)) +end diff --git a/sys/imio/impmlne3.x b/sys/imio/impmlne3.x new file mode 100644 index 00000000..f41c8e11 --- /dev/null +++ b/sys/imio/impmlne3.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> + +# IM_PMLNE3 -- Pixel mask line not empty. + +bool procedure im_pmlne3 (im, lineno, bandno) + +pointer im #I image descriptor +int lineno #I line number +int bandno #I band number + +long v[IM_MAXDIM] +bool pm_linenotempty() + +begin + call amovkl (1, v, IM_MAXDIM) + v[2] = lineno + v[3] = bandno + + return (pm_linenotempty (IM_PL(im), v)) +end diff --git a/sys/imio/impmlnev.x b/sys/imio/impmlnev.x new file mode 100644 index 00000000..d6d03b87 --- /dev/null +++ b/sys/imio/impmlnev.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> + +# IM_PMLNEV -- Test if a mask image line is nonempty. + +bool procedure im_pmlnev (im, v) + +pointer im #I image descriptor +long v[IM_MAXDIM] #I vector coordinates of image line + +bool pm_linenotempty() + +begin + return (pm_linenotempty (IM_PL(im), v)) +end diff --git a/sys/imio/impmmap.x b/sys/imio/impmmap.x new file mode 100644 index 00000000..21ec5038 --- /dev/null +++ b/sys/imio/impmmap.x @@ -0,0 +1,92 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include <pmset.h> +include <imhdr.h> +include <imio.h> + +# IM_PMMAP -- Map a pixel list as a virtual mask image. If the mask name +# given is "BPM" (upper case) the bad pixel list for the reference image is +# opened, if the mask name is "EMPTY" an empty mask is opened, otherwise the +# mask name is taken to be the name of the file in which the mask is stored. +# If there is no bad pixel list for the image an empty mask is opened. +# If a more specialized mask is needed it should be opened or generated via +# explicit calls to the PMIO package, and then mapped onto an image descriptor +# with IM_PMMAPO. + +pointer procedure im_pmmap (mask, mode, ref_im) + +char mask[ARB] #I mask file name or "BPM" +int mode #I mode and flag bits +pointer ref_im #I reference image + +pointer sp, cluster, section, pl, im, hp +int acmode, flags, sz_svhdr, ip +pointer im_pmmapo(), im_pmopen() +int btoi(), ctoi(), envfind() +errchk im_pmopen, im_pmopen + +begin + call smark (sp) + call salloc (cluster, SZ_PATHNAME, TY_CHAR) + call salloc (section, SZ_FNAME, TY_CHAR) + + acmode = PL_ACMODE(mode) + flags = PL_FLAGS(mode) + + # If opening an existing mask, get a buffer for the saved mask image + # header. + + if (acmode != NEW_IMAGE && acmode != NEW_COPY) { + ip = 1 + if (envfind ("min_lenuserarea", Memc[section], SZ_FNAME) > 0) { + if (ctoi (Memc[section], ip, sz_svhdr) <= 0) + sz_svhdr = MIN_LENUSERAREA + } else + sz_svhdr = MIN_LENUSERAREA + call salloc (hp, sz_svhdr, TY_CHAR) + } + + # Parse the full image specification into a root name and an image + # section. + call imgimage (mask, Memc[cluster], SZ_PATHNAME) + call imgsection (mask, Memc[section], SZ_FNAME) + + # Open the mask. + pl = im_pmopen (Memc[cluster], mode, Memc[hp], sz_svhdr, ref_im) + + # Map the mask onto an image descriptor. + iferr (im = im_pmmapo (pl, ref_im)) { + call pl_close (pl) + call erract (EA_ERROR) + } else { + call strcpy (mask, IM_NAME(im), SZ_IMNAME) + if (acmode != NEW_IMAGE && acmode != NEW_COPY) + call im_pmldhdr (im, hp) + } + + # Set flag to close PL descriptor at IMUNMAP time. + IM_PLFLAGS(im) = or (IM_PLFLAGS(im), PL_CLOSEPL) + + # If we are creating a new mask of type boolean, set bool flag so + # that imopsf will make a boolean mask. + + if (acmode == NEW_IMAGE || acmode == NEW_COPY) + if (and (flags, BOOLEAN_MASK) != 0) + IM_PLFLAGS(im) = or (IM_PLFLAGS(im), PL_BOOL) + + # Set access mode for mask, and mask update at unmap flag. + IM_ACMODE(im) = acmode + IM_UPDATE(im) = btoi (acmode != READ_ONLY) + + IM_NPHYSDIM(im) = IM_NDIM(im) + call amovl (IM_LEN(im,1), IM_PHYSLEN(im,1), IM_MAXDIM) + call amovl (IM_LEN(im,1), IM_SVLEN(im,1), IM_MAXDIM) + + # Set up section transformation. + if (ref_im == NULL && Memc[section] != EOS) + call imisec (im, Memc[section]) + + call sfree (sp) + return (im) +end diff --git a/sys/imio/impmmapo.x b/sys/imio/impmmapo.x new file mode 100644 index 00000000..318ce573 --- /dev/null +++ b/sys/imio/impmmapo.x @@ -0,0 +1,62 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <pmset.h> +include <imhdr.h> +include <imio.h> +include <plio.h> + +# IM_PMMAPO -- Map an open pixel list onto an image descriptor, so that the +# pixel list may be accessed as a virtual "mask image". If a reference image +# is specified the mask image inherits any image section etc., defined for +# the reference image. + +pointer procedure im_pmmapo (pl, ref_im) + +pointer pl #I mask descriptor +pointer ref_im #I reference image or NULL + +pointer im +long axlen[IM_MAXDIM] +int naxes, depth, i +errchk syserr, immapz, pl_gsize +pointer immapz() + +begin + # Get the mask size. + call pl_gsize (pl, naxes, axlen, depth) + + # Verify the size if there is a reference image. + if (ref_im != NULL) + do i = 1, max (naxes, IM_NPHYSDIM(ref_im)) + if (IM_SVLEN(ref_im,i) != axlen[i]) + call syserr (SYS_IMPLSIZE) + + # Open an image header for the mask. + call iki_init() + im = immapz ("dev$null", NEW_IMAGE, 0) + + # Set up the image descriptor. + IM_NDIM(im) = naxes + IM_PIXTYPE(im) = TY_INT + call amovl (axlen, IM_LEN(im,1), IM_MAXDIM) + + IM_PL(im) = pl + IM_PLREFIM(im) = ref_im + IM_PLFLAGS(im) = 0 + IM_MIN(im) = 0 + IM_MAX(im) = 2 ** depth - 1 + IM_LIMTIME(im) = IM_MTIME(im) + 1 + IM_UPDATE(im) = NO + + PM_REFIM(pl) = im + if (ref_im != NULL) + PM_MAPXY(pl) = IM_SECTUSED(ref_im) + else + PM_MAPXY(pl) = NO + + # Further setup of the image descriptor is carried out by IMOPSF + # when the first i/o access occurs, as for a regular image. + + return (im) +end diff --git a/sys/imio/impmopen.x b/sys/imio/impmopen.x new file mode 100644 index 00000000..bd8a564b --- /dev/null +++ b/sys/imio/impmopen.x @@ -0,0 +1,99 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <error.h> +include <pmset.h> +include <imhdr.h> +include <imio.h> + +# IM_PMOPEN -- Open an image mask. If the mask name is given is "BPM" (upper +# case) the bad pixel list for the reference image is opened, if the mask name +# is "EMPTY" an empty mask is opened, otherwise the mask name is taken to be +# the name of the file in which the mask is stored. If there is no bad pixel +# list for the image an empty mask is opened. If a more specialized mask is +# needed it should be opened or generated via explicit calls to the PMIO +# package. + +pointer procedure im_pmopen (mask, mode, title, maxch, ref_im) + +char mask[ARB] #I mask file name or "BPM" +int mode #I mode and flag bits +char title[maxch] #O mask title +int maxch #I max chars out +pointer ref_im #I reference image + +pointer sp, fname, pl, b_pl +long axlen[PL_MAXDIM], v[PL_MAXDIM] +int acmode, flags, naxes, depth + +bool streq() +pointer pl_open(), pl_create() +errchk syserr, pl_open, pl_create, pl_loadf, pl_loadim + +string s_empty "EMPTY" # the empty mask +string s_bpl "BPM" # the reference image bad pixel list + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + + acmode = PL_ACMODE(mode) + flags = PL_FLAGS(mode) + + # Get mask name for the BPM for the given reference image. + if (streq (mask, s_bpl)) { + if (ref_im == NULL) + call syserr (SYS_IMPLNORI) + iferr (call imgstr (ref_im, s_bpl, Memc[fname], SZ_FNAME)) + call strcpy (s_empty, Memc[fname], SZ_FNAME) + } else + call strcpy (mask, Memc[fname], SZ_FNAME) + + pl = pl_open (NULL) + + # Open the named mask. + if (acmode != NEW_IMAGE && acmode != NEW_COPY) { + if (streq (Memc[fname], s_empty)) { + if (ref_im == NULL) { + call pl_close (pl) + call syserr (SYS_IMPLNORI) + } + call pl_ssize (pl, IM_NPHYSDIM(ref_im), IM_SVLEN(ref_im,1), 1) + } else { + iferr (call pl_loadf (pl, Memc[fname], title, maxch)) { + call pl_close (pl) + pl = pl_open (NULL) + iferr (call pl_loadim (pl, Memc[fname], title, maxch)) { + call pl_close (pl) + call erract (EA_ERROR) + } + } + } + + # Modify the mask according to the given flags, if any. + if (flags != 0) { + call pl_gsize (pl, naxes, axlen, depth) + call amovkl (1, v, PL_MAXDIM) + + if (and (flags, BOOLEAN_MASK) != 0 && depth > 1) { + b_pl = pl_create (naxes, axlen, 1) + + if (and (flags, INVERT_MASK) != 0) { + call pl_rop (pl, v, b_pl, v, axlen, PIX_SRC) + call amovkl (1, v, PL_MAXDIM) + call pl_rop (b_pl, v, b_pl, v, axlen, PIX_NOT(PIX_SRC)) + } else { + call pl_rop (pl, v, b_pl, v, axlen, PIX_SRC) + } + + call pl_close (pl) + pl = b_pl + + } else if (and (flags, INVERT_MASK) != 0) + call pl_rop (pl, v, pl, v, axlen, PIX_NOT(PIX_SRC)) + } + } + + call sfree (sp) + return (pl) +end diff --git a/sys/imio/impmsne1.x b/sys/imio/impmsne1.x new file mode 100644 index 00000000..044aee81 --- /dev/null +++ b/sys/imio/impmsne1.x @@ -0,0 +1,16 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imio.h> + +# IM_PMSNE1 -- Pixel mask section not empty. + +bool procedure im_pmsne1 (im, x1, x2) + +pointer im #I image descriptor +int x1, x2 #I section to be tested + +bool pm_sectnotempty() + +begin + return (pm_sectnotempty (IM_PL(im), x1, x2, 1)) +end diff --git a/sys/imio/impmsne2.x b/sys/imio/impmsne2.x new file mode 100644 index 00000000..42cb7141 --- /dev/null +++ b/sys/imio/impmsne2.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imio.h> + +# IM_PMSNE2 -- Pixel mask section not empty. + +bool procedure im_pmsne2 (im, x1, x2, y1, y2) + +pointer im #I image descriptor +int x1, x2 #I section to be tested +int y1, y2 #I section to be tested + +long vs[2], ve[2] +bool pm_sectnotempty() + +begin + vs[1] = x1; vs[2] = y1 + ve[1] = x2; ve[2] = y2 + + return (pm_sectnotempty (IM_PL(im), vs, ve, 2)) +end diff --git a/sys/imio/impmsne3.x b/sys/imio/impmsne3.x new file mode 100644 index 00000000..15a132d6 --- /dev/null +++ b/sys/imio/impmsne3.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imio.h> + +# IM_PMSNE3 -- Pixel mask section not empty. + +bool procedure im_pmsne3 (im, x1,x2, y1,y2, z1,z2) + +pointer im #I image descriptor +int x1, x2 #I section to be tested +int y1, y2 #I section to be tested +int z1, z2 #I section to be tested + +long vs[3], ve[3] +bool pm_sectnotempty() + +begin + vs[1] = x1; vs[2] = y1; vs[3] = z1 + ve[1] = x2; ve[2] = y2; ve[3] = z2 + + return (pm_sectnotempty (IM_PL(im), vs, ve, 3)) +end diff --git a/sys/imio/impmsnev.x b/sys/imio/impmsnev.x new file mode 100644 index 00000000..f50fefb6 --- /dev/null +++ b/sys/imio/impmsnev.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> + +# IM_PMSNEV -- Test if a mask image section is nonempty. + +bool procedure im_pmsnev (im, vs, ve, ndim) + +pointer im #I image descriptor +long vs[IM_MAXDIM] #I vector coordinates of start of section +long ve[IM_MAXDIM] #I vector coordinates of end of section +int ndim #I dimensionality of section + +bool pm_sectnotempty() + +begin + return (pm_sectnotempty (IM_PL(im), vs, ve, ndim)) +end diff --git a/sys/imio/impnl.gx b/sys/imio/impnl.gx new file mode 100644 index 00000000..27acdfae --- /dev/null +++ b/sys/imio/impnl.gx @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> + +# IMPNL -- Put the next line to an image of any dimension or datatype. +# This is a sequential operator. The index vector V should be initialized +# before the first call to the first line to be written. Each call increments +# the leftmost subscript by one, until V equals IM_LEN, at which time EOF +# is returned. Subsequent writes are ignored. + +int procedure impnl$t (imdes, lineptr, v) + +pointer imdes +pointer lineptr # on output, points to the pixels +long v[IM_MAXDIM] # loop counter +int npix +int impnln() +extern imfls$t() +errchk impnln + +begin + if (IM_FLUSH(imdes) == YES) + call zcall1 (IM_FLUSHEPA(imdes), imdes) + + npix = impnln (imdes, lineptr, v, TY_PIXEL) + if (IM_FLUSH(imdes) == YES) + call zlocpr (imfls$t, IM_FLUSHEPA(imdes)) + + return (npix) +end diff --git a/sys/imio/impnln.x b/sys/imio/impnln.x new file mode 100644 index 00000000..f5197768 --- /dev/null +++ b/sys/imio/impnln.x @@ -0,0 +1,109 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include <imio.h> + +# IMPNLN -- Put the next line to an image of any dimension or datatype. +# This is a sequential operator. The index vector V should be initialized +# to the first line to be written before the first call. Each call increments +# the leftmost subscript by one, until V equals IM_LEN. EOF is returned +# when the last line in the image has been written. + +int procedure impnln (im, lineptr, v, dtype) + +pointer im +pointer lineptr # on output, points to the pixels +long v[IM_MAXDIM] # loop counter +int dtype # eventual datatype of pixels + +long lineoff, line, band, offset +int dim, ndim, junk, sz_pixel, sz_dtype, fd, nchars, pixtype +long vs[IM_MAXDIM], ve[IM_MAXDIM], unit_v[IM_MAXDIM], npix + +int imloop() +pointer imgobf(), fwritep() +errchk imgobf, fwritep, imerr, imopsf +define retry_ 91 +define oob_ 92 +define misaligned_ 93 + +int sizeof() +include <szpixtype.inc> +data unit_v /IM_MAXDIM * 1/ + +begin + ndim = IM_NDIM(im) + if (ndim == 0) + return (EOF) + + npix = IM_LEN(im,1) # write entire line + pixtype = IM_PIXTYPE(im) + sz_pixel = pix_size[pixtype] + sz_dtype = sizeof(pixtype) + + # Perform "zero trip" check (V >= VE), before entering "loop". + if (v[ndim] > IM_LEN(im,ndim)) + return (EOF) +retry_ + if (IM_FAST(im) == YES && pixtype == dtype && ndim <= 3) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + goto retry_ + } + + # Lineoff is the dimensionless line offset in the pixel storage + # file (which we assume to be in line storage mode). + + lineoff = 0 + if (ndim > 1) { + line = v[2] + if (line < 1 || line > IM_LEN(im,2)) + goto oob_ + lineoff = line - 1 + if (ndim > 2) { + band = v[3] + if (band < 1 || band > IM_LEN(im,3)) +oob_ call imerr (IM_NAME(im), SYS_IMREFOOB) + lineoff = lineoff + (band - 1) * IM_PHYSLEN(im,2) + } + } + + # Reference directly into the FIO buffer. If the line straddles + # FIO block boundaries then fwritep will return error and we must + # use a separate buffer. + + offset = lineoff * IM_PHYSLEN(im,1) * sz_pixel + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * sz_pixel + iferr (lineptr = (fwritep (fd, offset, nchars) - 1) / sz_pixel + 1) + goto misaligned_ + + } else { +misaligned_ + # Prepare section descriptor vectors. + vs[1] = 1 + ve[1] = npix + do dim = 2, ndim { + vs[dim] = v[dim] + ve[dim] = v[dim] + } + + # Get the output line buffer. + lineptr = imgobf (im, vs, ve, ndim, dtype) + IM_FLUSH(im) = YES + } + + # Increment loop vector (cannot use nested loops since the dimension + # of the image is variable). Note this loop vector references + # logical section coordinates. + + if (ndim == 1) + v[1] = IM_LEN(im,1) + 1 + else if (ndim == 2 && IM_FAST(im) == YES) + v[2] = v[2] + 1 + else + junk = imloop (v, unit_v, IM_LEN(im,1), unit_v, ndim) + + return (npix) +end diff --git a/sys/imio/imps1.gx b/sys/imio/imps1.gx new file mode 100644 index 00000000..9e225923 --- /dev/null +++ b/sys/imio/imps1.gx @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMPS1? -- Put a section to an apparently one dimensional image. + +pointer procedure imps1$t (im, x1, x2) + +pointer im # image header pointer +int x1 # first column +int x2 # last column + +pointer impgs$t(), impl1$t() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1)) + return (impl1$t (im)) + else + return (impgs$t (im, long(x1), long(x2), 1)) +end diff --git a/sys/imio/imps2.gx b/sys/imio/imps2.gx new file mode 100644 index 00000000..ee5ac4a3 --- /dev/null +++ b/sys/imio/imps2.gx @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMPS2? -- Put a section to an apparently two dimensional image. + +pointer procedure imps2$t (im, x1, x2, y1, y2) + +pointer im +int x1, x2, y1, y2 +long vs[2], ve[2] +pointer impgs$t(), impl2$t() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1) && y1 == y2) + return (impl2$t (im, y1)) + else { + vs[1] = x1 + ve[1] = x2 + + vs[2] = y1 + ve[2] = y2 + + return (impgs$t (im, vs, ve, 2)) + } +end diff --git a/sys/imio/imps3.gx b/sys/imio/imps3.gx new file mode 100644 index 00000000..490ee531 --- /dev/null +++ b/sys/imio/imps3.gx @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMPS3? -- Put a section to an apparently three dimensional image. + +pointer procedure imps3$t (im, x1, x2, y1, y2, z1, z2) + +pointer im +int x1, x2, y1, y2, z1, z2 +long vs[3], ve[3] +pointer impgs$t(), impl3$t() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1) && y1 == y2 && z1 == z2) + return (impl3$t (im, y1, z1)) + else { + vs[1] = x1 + ve[1] = x2 + + vs[2] = y1 + ve[2] = y2 + + vs[3] = z1 + ve[3] = z2 + + return (impgs$t (im, vs, ve, 3)) + } +end diff --git a/sys/imio/imrbpx.x b/sys/imio/imrbpx.x new file mode 100644 index 00000000..ea54aeff --- /dev/null +++ b/sys/imio/imrbpx.x @@ -0,0 +1,129 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imset.h> +include <imio.h> + +# IMRBPX -- Read a line segment from an image with boundary extension. The +# line segment is broken up into three parts, i.e., left, center, and right. +# The endpoints of each segment, if out of bounds, are mapped back into the +# image using the current boundary extension technique. The mapped line +# segment in physical coordinates is then extracted; if an image section is +# defined the section transformation has already been performed before we are +# called. After all three segments have been extracted the entire line +# segment is flipped if the flip flag is set. + +procedure imrbpx (im, obuf, totpix, v, vinc) + +pointer im # image descriptor +char obuf[ARB] # typeless output buffer +int totpix # total number of pixels to extract +long v[ARB] # vector pointer to start of line segment +long vinc[ARB] # step on each axis + +bool oob +char pixval[8] +int npix, ndim, sz_pixel, btype, op, off, step, xstep, imtyp, i, j, k, ncp +long xs[3], xe[3], x1, x2, p, v1[IM_MAXDIM], v2[IM_MAXDIM], linelen +errchk imrdpx +include <szpixtype.inc> + +begin + sz_pixel = pix_size[IM_PIXTYPE(im)] + ndim = IM_NPHYSDIM(im) + + # Cache the left and right endpoints of the line segment and the + # image line length. + + xstep = abs (IM_VSTEP(im,1)) + linelen = IM_SVLEN(im,1) + x1 = v[1] + x2 = x1 + (totpix * xstep) - 1 + + # Compute the endpoints of the line segment in the three x-regions of + # the image. + + xs[1] = x1 # left oob region + xe[1] = min (0, x2) + xs[2] = max (x1, 1) # central inbounds region + xe[2] = min (x2, linelen) + xs[3] = max (x1, linelen + 1) # right oob region + xe[3] = x2 + + # Perform bounds mapping on the entire vector. The mapping for all + # dimensions higher than the first is invariant in what follows. + + call imbtran (im, v, v1, ndim) + + # Copy V1 to V2 and determine if the whole thing is out of bounds. + oob = false + do i = 2, ndim { + p = v1[i] + v2[i] = p + if (p < 1 || p > IM_SVLEN(im,i)) + oob = true + } + + # Extract that portion of the line segment falling in each region + # into the output buffer. There are two classes of boundary extension + # techniques, those that fill the out of bounds area with a constant, + # and those that map the oob area into a vector lying within the bounds + # of the image. + + btype = IM_VTYBNDRY(im) + imtyp = IM_PIXTYPE(im) + op = 1 + + do i = 1, 3 { + # Skip to next region if there are no pixels in this region. + npix = (xe[i] - xs[i]) / xstep + 1 + if (npix <= 0) + next + + # Map the endpoints of the segment. + call imbtran (im, xs[i], v1[1], 1) + call imbtran (im, xe[i], v2[1], 1) + + # Compute the starting vector V1, step in X, and the number of + # pixels in the region allowing for subsampling. + + if (v1[1] > v2[1]) { + step = -xstep + v1[1] = v2[1] + } else + step = xstep + + # Perform the boundary extension. + ncp = sz_pixel + call aclrc (pixval, 8) + if ((i == 2 && !oob) || btype == BT_REFLECT || btype == BT_WRAP) + call imrdpx (im, obuf[op], npix, v1, step) + else { + # Use constant or value of nearest boundary pixel. + if (btype == BT_CONSTANT) + call impakr (IM_OOBPIX(im), pixval, 1, IM_PIXTYPE(im)) + else + call imrdpx (im, pixval, 1, v1, step) + + if ((imtyp == TY_INT || imtyp == TY_LONG) && + SZ_INT != SZ_INT32) { + call iupk32 (pixval, pixval, 2) + ncp = sz_pixel * 2 + } + + # Fill the output array. + off = op - 1 + do j = 1, npix { + do k = 1, ncp + obuf[off+k] = pixval[k] + off = off + ncp + } + } + + op = op + (npix * ncp) + } + + # Flip the output array if the step size in X is negative. + if (vinc[1] < 0) + call imaflp (obuf, totpix, sz_pixel) +end diff --git a/sys/imio/imrdpx.x b/sys/imio/imrdpx.x new file mode 100644 index 00000000..1c7d3564 --- /dev/null +++ b/sys/imio/imrdpx.x @@ -0,0 +1,112 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> +include <syserr.h> +include <plset.h> +include <imhdr.h> +include <imio.h> + +# IMRDPX -- Read NPIX * STEP pixels, stored contiguously in the pixel storage +# file, starting with the pixel whose coordinates are given by the vector V, +# into the buffer BUF. If the step size is not unity, accumulate pixels 1, +# 1 + STEP, and so on for a total of NPIX pixels, at the start of the buffer. +# If VINC is negative, flip the array of NPIX pixels end for end. + +procedure imrdpx (im, obuf, npix, v, xstep) + +pointer im # image descriptor +char obuf[ARB] # output buffer +int npix # number of pixels to extract +long v[IM_MAXDIM] # physical coords of first pixel +int xstep # step between pixels in X (neg for a flip) + +pointer pl +long offset +int sz_pixel, nbytes, fd, op, step, nchars, n + +char zbuf[1024] + +int read() +long imnote() +errchk imerr, seek, read, pl_glpi, pl_glri +include <szpixtype.inc> + +begin + step = abs (xstep) + if (v[1] < 1 || ((npix-1) * step) + v[1] > IM_SVLEN(im,1)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + pl = IM_PL(im) + fd = IM_PFD(im) + offset = imnote (im, v) + sz_pixel = pix_size[IM_PIXTYPE(im)] + + # If the step size is small, read in all the data at once and + # resample. Requires a buffer STEP times larger than necessary, + # but is most efficient for small step sizes. If the step size + # is very large, read each pixel with a separate READ call (buffer + # size no larger than necessary). Most efficient technique for very + # large step sizes. + + if (pl != NULL) { + # Read from a pixel list. Range list i/o is permitted at this + # level only if no pixel conversions are required, i.e., only if + # "fast" i/o is enabled. Otherwise, we must return pixels here + # and then convert back to a range list after the conversions. + + n = ((npix-1) * step + 1) + if (and (IM_PLFLAGS(im), PL_FAST+PL_RLIO) == PL_FAST+PL_RLIO) + call pl_glri (pl, v, obuf, 0, n, PIX_SRC) + else { + call pl_glpi (pl, v, obuf, 0, n, PIX_SRC) + if (step > 1) + call imsamp (obuf, obuf, npix, sz_pixel, step) + } + + } else if (step <= IM_MAXSTEP) { + # Seek to the point V in the pixel storage file. Compute size + # of transfer. Read in the data, resample. + + call seek (fd, offset) + nchars = ((npix-1) * step + 1) * sz_pixel + + if (read (fd, obuf, nchars) != nchars) + call imerr (IM_NAME(im), SYS_IMNOPIX) + if (step > 1) + call imsamp (obuf, obuf, npix, sz_pixel, step) + + } else { + # Seek and read each pixel directly into the output buffer. + nchars = npix * sz_pixel + + for (op=1; op <= nchars; op=op+sz_pixel) { + call seek (fd, offset) + if (read (fd, obuf[op], sz_pixel) < sz_pixel) + call imerr (IM_NAME(im), SYS_IMNOPIX) + offset = offset + (sz_pixel * step) + } + } + + # Flip the pixel array end for end. + if (xstep < 0) + call imaflp (obuf, npix, sz_pixel) + + # Byte swap if necessary. + nbytes = npix * sz_pixel * SZB_CHAR + if (IM_SWAP(im) == YES) { + switch (sz_pixel * SZB_CHAR) { + case 2: + call bswap2 (obuf, 1, obuf, 1, nbytes) + case 4: + call bswap4 (obuf, 1, obuf, 1, nbytes) + case 8: + call bswap8 (obuf, 1, obuf, 1, nbytes) + } + } + + if (pl == NULL) { + if ((IM_PIXTYPE(im) == TY_INT || IM_PIXTYPE(im) == TY_LONG) && + SZ_INT != SZ_INT32) + call iupk32 (obuf, obuf, npix) + } +end diff --git a/sys/imio/imrename.x b/sys/imio/imrename.x new file mode 100644 index 00000000..9e0f08bf --- /dev/null +++ b/sys/imio/imrename.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMRENAME -- Rename an image. + +procedure imrename (old, new) + +char old[ARB] # old image name +char new[ARB] # new image name + +begin + call iki_init() + call iki_rename (old, new) +end diff --git a/sys/imio/imrmbufs.x b/sys/imio/imrmbufs.x new file mode 100644 index 00000000..1e0d7c5a --- /dev/null +++ b/sys/imio/imrmbufs.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imio.h> + +# IMRMBUFS -- Free any pixel data buffers currently allocated to an image. + +procedure imrmbufs (im) + +pointer im # image descriptor + +int i +pointer ibdes, obdes + +begin + ibdes = IM_IBDES(im) + obdes = IM_OBDES(im) + + if (ibdes != NULL) { + for (i=0; i < IM_VNBUFS(im); i=i+1) + call mfree (BD_BUFPTR(ibdes + LEN_BDES * i), TY_CHAR) + call mfree (ibdes, TY_STRUCT) + } + + if (obdes != NULL) { + call mfree (BD_BUFPTR(obdes), TY_CHAR) + call mfree (obdes, TY_STRUCT) + } + + IM_IBDES(im) = NULL + IM_OBDES(im) = NULL +end diff --git a/sys/imio/imsamp.x b/sys/imio/imsamp.x new file mode 100644 index 00000000..43e144c9 --- /dev/null +++ b/sys/imio/imsamp.x @@ -0,0 +1,61 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMSAMP -- Subsample a vector. + +procedure imsamp (a, b, npix, sz_pixel, step) + +char a[ARB], b[ARB] +int npix, sz_pixel, step, i, j, in, out, delta_in + +begin + switch (sz_pixel) { + case SZ_SHORT: + call imsmps (a, b, npix, step) + case SZ_LONG: + call imsmpl (a, b, npix, step) + + default: # flip odd sized elements + in = 0 + out = 0 + delta_in = sz_pixel * step + + do j = 1, npix { + do i = 1, sz_pixel + b[out+i] = a[in+i] + in = in + delta_in + out = out + sz_pixel + } + } +end + + +# IMSMPS -- Sample an array of SHORT sized elements. + +procedure imsmps (a, b, npix, step) + +short a[ARB], b[npix] +int npix, step, ip, op + +begin + ip = 1 + do op = 1, npix { + b[op] = a[ip] + ip = ip + step + } +end + + +# IMSMPL -- Sample an array of LONG sized elements. + +procedure imsmpl (a, b, npix, step) + +long a[ARB], b[npix] +int npix, step, ip, op + +begin + ip = 1 + do op = 1, npix { + b[op] = a[ip] + ip = ip + step + } +end diff --git a/sys/imio/imsetbuf.x b/sys/imio/imsetbuf.x new file mode 100644 index 00000000..3938f30a --- /dev/null +++ b/sys/imio/imsetbuf.x @@ -0,0 +1,117 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <fset.h> +include <imio.h> + +# IMSETBUF -- Set the FIO file buffer size for the pixel storage file. +# We always make the buffer size equal to an integral number of image lines +# if possible. The actual number of image lines chosen depends on the +# type of access expected and the size of an image line. If image lines are +# very large the FIO buffer will be shorter than a line. We also compute +# IM_FAST, the flag determining whether or not direct access to the FIO +# buffer is permissible. + +procedure imsetbuf (fd, im) + +int fd # pixel storage file +pointer im # image header pointer + +long imsize, bufoff, blkoff +int maxlines, bufsize, szline, nlines, i +int opt_bufsize, max_bufsize, dev_blksize +int fstati(), sizeof() + +begin + IM_FAST(im) = NO + + max_bufsize = fstati (fd, F_MAXBUFSIZE) + opt_bufsize = fstati (fd, F_OPTBUFSIZE) + dev_blksize = max (1, fstati (fd, F_BLKSIZE)) + + szline = IM_PHYSLEN(im,1) * sizeof(IM_PIXTYPE(im)) + imsize = szline + do i = 2, IM_NDIM(im) + imsize = imsize * IM_PHYSLEN(im,i) + + # Compute the suggested buffer size. If bufsize is set externally + # and buffrac is disabled (zero) then we try to use the bufsize + # value given. If buffrac is enabled then we compute a bufsize + # based on this, and use the larger of this value or the default + # bufsize, but not more than DEF_MAXFIOBUFSIZE. The parameter + # buffrac specifies the size of an image buffer as a fraction, + # in percent, of the total size of the image. + # + # For example if buffrac=10, the default buffer size will be either + # "bufsize", or 10% of the full image size, whichever is larger, but + # not more than DEF_MAXFIOBUFSIZE. The intent of buffrac is to + # provide an adaptive mechanism for adjusting the size of the image + # buffers to match the image being accessed. For small images the + # buffer will be the default bufsize (or less if the image is + # smaller than this). For very large images the buffer size will + # increase until the builtin default maximum value DEF_MAXFIOBUFSIZE + # is reached. If more control is needed, buffrac can be set to zero, + # and bufsize will specify the buffer size to be used. Even if + # buffrac is enabled, bufsize can be set to a large value to force + # a large buffer to be used. + + bufsize = IM_VBUFSIZE(im) + if (IM_VBUFFRAC(im) > 0) + bufsize = max(bufsize, min(IM_VBUFMAX(im), + imsize / 100 * min(100,IM_VBUFFRAC(im)) )) + + # Compute max number of image lines that will fit in default buffer. + if (max_bufsize > 0) + nlines = min(max_bufsize,max(opt_bufsize,bufsize)) / szline + else + nlines = bufsize / szline + + # Compute final number of image lines in buffer. + if (nlines == 0) { + # Image lines are very long. Use a buffer smaller than a line. + call fseti (fd, F_ADVICE, SEQUENTIAL) + return + } else if (IM_VADVICE(im) == RANDOM) { + # Always buffer at least one line if the lines are short. + nlines = 1 + } + + # Don't make the buffer any larger than the image. + maxlines = 1 + do i = 2, IM_NDIM(im) + maxlines = maxlines * IM_PHYSLEN(im,i) + nlines = min (nlines, maxlines) + + # Tell FIO to align the first file buffer to the device block + # containing the first image line. Ideally the image line will + # start on a block boundary but this does not have to be the case. + + bufoff = (IM_PIXOFF(im) - 1) / dev_blksize * dev_blksize + 1 + blkoff = IM_PIXOFF(im) - bufoff + call fseti (fd, F_FIRSTBUFOFF, bufoff) + + # An integral number of image lines fit inside the default size + # buffer. Tell FIO the minimum size buffer to use. FIO will actually + # allocate a slightly larger buffer if bufsize is not an integral + # number of device blocks. + + bufsize = blkoff + nlines * szline + call fseti (fd, F_BUFSIZE, bufsize) + + # If a FIO buffer will hold at least two image lines, if no image + # section was given, if there is only one input line buffer, if + # we are not going to be referencing out of bounds, and the pixel + # data is properly aligned in the pixel file, then FAST i/o (directly + # into the FIO buffer) is possible provided no datatype conversion + # or byte swapping is desired or required. If all these criteria + # are true enable fast i/o. + + if ((bufsize / szline >= 2 && IM_SECTUSED(im) == NO) && + (IM_VNBUFS(im) == 1 && IM_VNBNDRYPIX(im) == 0) && + (mod (IM_PIXOFF(im), sizeof(IM_PIXTYPE(im)))) == 1 && + IM_SWAP(im) == NO) { + + IM_FAST(im) = YES +IM_FAST(im) = NO + } +end diff --git a/sys/imio/imseti.x b/sys/imio/imseti.x new file mode 100644 index 00000000..9fd0bc2d --- /dev/null +++ b/sys/imio/imseti.x @@ -0,0 +1,90 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include <imset.h> +include <imio.h> +include <fset.h> + +# IMSETI -- Set an IMIO parameter of type integer (or pointer). For +# completeness this routine can be used to set real valued parameters, but +# obviously since the input value is integer a fractional value cannot be +# set. + +procedure imseti (im, param, value) + +pointer im #I image descriptor +int param #I parameter to be set +int value #I integer value of parameter + +int i +pointer ibdes +errchk calloc + +begin + switch (param) { + case IM_ADVICE: + IM_VADVICE(im) = value + case IM_BUFSIZE: + IM_VBUFSIZE(im) = value + case IM_BUFFRAC: + IM_VBUFFRAC(im) = value + case IM_BUFMAX: + IM_VBUFMAX(im) = value + case IM_COMPRESS: + IM_VCOMPRESS(im) = value + case IM_NBNDRYPIX: + IM_VNBNDRYPIX(im) = max (0, value) + case IM_TYBNDRY: + IM_VTYBNDRY(im) = value + case IM_BNDRYPIXVAL: + IM_OOBPIX(im) = real(value) + case IM_FLAGBADPIX: + IM_VFLAGBADPIX(im) = value + case IM_PIXFD: + IM_PFD(im) = value + case IM_WHEADER: + IM_UPDATE(im) = value + + case IM_PLDES: + IM_PL(im) = value + case IM_RLIO: + # Enable/disable range list i/o (for image masks). + if (value == YES) + IM_PLFLAGS(im) = or (IM_PLFLAGS(im), PL_RLIO) + else + IM_PLFLAGS(im) = and (IM_PLFLAGS(im), not(PL_RLIO)) + + case IM_NBUFS: + # Free any existing input buffers. + ibdes = IM_IBDES(im) + if (ibdes != NULL) + for (i=0; i < IM_VNBUFS(im); i=i+1) + call mfree (BD_BUFPTR(ibdes + LEN_BDES * i), TY_CHAR) + + # Change size of buffer pool. + IM_VNBUFS(im) = value + + # Reinit input buffer descriptors. The actual input buffers will + # be reallocated upon demand. + + if (ibdes != NULL) { + call mfree (IM_IBDES(im), TY_STRUCT) + call calloc (IM_IBDES(im), LEN_BDES * IM_VNBUFS(im), TY_STRUCT) + IM_NGET(im) = 0 + } + + case IM_CANCEL: + # Free any pixel data buffers associated with an image. + call imrmbufs (im) + + case IM_CLOSEFD: + # Set F_CLOSEFD on the pixel file. + IM_VCLOSEFD(im) = value + if (IM_PFD(im) != NULL) + call fseti (IM_PFD(im), F_CLOSEFD, value) + + default: + call imerr (IM_NAME(im), SYS_IMSETUNKPAR) + } +end diff --git a/sys/imio/imsetr.x b/sys/imio/imsetr.x new file mode 100644 index 00000000..b0287458 --- /dev/null +++ b/sys/imio/imsetr.x @@ -0,0 +1,25 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imset.h> +include <imio.h> + +# IMSETR -- Set an IMIO parameter to a real value. For completeness this +# routine can be used to set integer valued parameters, although if the +# value has a fractional part or requires more than 24 bits of precision +# the results may be unpredictable. + +procedure imsetr (im, param, value) + +pointer im #I image descriptor +int param #I parameter to be set +real value #I value of parameter + +begin + switch (param) { + case IM_BNDRYPIXVAL: + IM_OOBPIX(im) = value + default: + call imseti (im, param, nint(value)) + } +end diff --git a/sys/imio/imsinb.x b/sys/imio/imsinb.x new file mode 100644 index 00000000..d0c8eb60 --- /dev/null +++ b/sys/imio/imsinb.x @@ -0,0 +1,53 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> + +# IMSINB -- Determine whether or not a section is in bounds. Out of bounds +# references are permissible if boundary extension is enabled. The actual +# dimensionality of the image need not agree with that of the section. + +int procedure imsinb (im, vs, ve, ndim) + +pointer im # image descriptor +long vs[ARB], ve[ARB] # logical section +int ndim # dimensionality of section + +int i +int lo, hi, bwidth +define oob_ 91 + +begin + # First check if the section is entirely within bounds. If this is the + # case no boundary extension will be required, making optimization + # possible. + + do i = 1, ndim { + hi = IM_LEN(im,i) + if (vs[i] < 1 || vs[i] > hi) + goto oob_ + if (ve[i] < 1 || ve[i] > hi) + goto oob_ + } + + return (YES) # section is within bounds + + # There is at least one out of bounds reference. Check that all such + # references are within NBNDRYPIX of the nearest boundary. NDIM may + # be greater than IM_NDIM, since IMIO sets the lengths of the excess + # dimensions to 1. In effect every image has up to MAXDIM dimensions. + oob_ + bwidth = IM_VNBNDRYPIX(im) + lo = 1 - bwidth + hi = 1 + bwidth + + do i = 1, ndim { + hi = IM_LEN(im,i) + bwidth + if (vs[i] < lo || vs[i] > hi) + return (ERR) # section is illegal + if (ve[i] < lo || ve[i] > hi) + return (ERR) + } + + return (NO) # section is oob but legal +end diff --git a/sys/imio/imsslv.x b/sys/imio/imsslv.x new file mode 100644 index 00000000..2cc5e2a8 --- /dev/null +++ b/sys/imio/imsslv.x @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> + +# IMSSLV -- Given two vectors (VS, VE) defining the starting and ending +# physical coordinates of the two pixels defining an image section, +# initialize the "loop index" vector V, and the "loop increment" vector, +# VINC. Compute NPIX, the number of pixels in a line segment. + +procedure imsslv (im, vs, ve, v, vinc, npix) + +pointer im +long vs[IM_MAXDIM], ve[IM_MAXDIM] +long v[IM_MAXDIM], vinc[IM_MAXDIM], npix, step +int i + +begin + # Determine the direction in which each dimension is to be + # traversed. + + do i = 1, IM_NPHYSDIM(im) { + step = abs (IM_VSTEP(im,i)) + if (vs[i] <= ve[i]) + vinc[i] = step + else + vinc[i] = -step + } + + # Initialize the extraction vector (passed to IMRDS? to read a + # contiguous array of pixels). Compute the length of a line, + # allowing for decimation by the step size. + + do i = 1, IM_NPHYSDIM(im) + v[i] = vs[i] + + if (vs[1] > ve[1]) + v[1] = ve[1] + + npix = (ve[1] - vs[1]) / vinc[1] + 1 +end diff --git a/sys/imio/imstati.x b/sys/imio/imstati.x new file mode 100644 index 00000000..0697911b --- /dev/null +++ b/sys/imio/imstati.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include <imset.h> +include <imio.h> + +# IMSTATI -- Get an IMIO option of type integer. + +int procedure imstati (im, option) + +pointer im #I image descriptor +int option #I imset option being queried + +begin + switch (option) { + case IM_ADVICE: + return (IM_VADVICE(im)) + case IM_BUFSIZE: + return (IM_VBUFSIZE(im)) + case IM_BUFFRAC: + return (IM_VBUFFRAC(im)) + case IM_BUFMAX: + return (IM_VBUFMAX(im)) + case IM_NBUFS: + return (IM_VNBUFS(im)) + case IM_COMPRESS: + return (IM_VCOMPRESS(im)) + case IM_NBNDRYPIX: + return (IM_VNBNDRYPIX(im)) + case IM_TYBNDRY: + return (IM_VTYBNDRY(im)) + case IM_FLAGBADPIX: + return (IM_VFLAGBADPIX(im)) + case IM_PIXFD: + return (IM_PFD(im)) + case IM_CLOSEFD: + return (IM_VCLOSEFD(im)) + case IM_WHEADER: + return (IM_UPDATE(im)) + case IM_PLDES: + return (IM_PL(im)) + case IM_RLIO: + if (and (IM_PLFLAGS(im), PL_RLIO) != 0) + return (YES) + else + return (NO) + default: + call imerr (IM_NAME(im), SYS_IMSTATUNKPAR) + } +end diff --git a/sys/imio/imstatr.x b/sys/imio/imstatr.x new file mode 100644 index 00000000..871cdca1 --- /dev/null +++ b/sys/imio/imstatr.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imset.h> +include <imio.h> + +# IMSTATR -- Get the real value of an IMIO parameter. + +real procedure imstatr (im, param) + +pointer im #I image descriptor +int param #I parameter to be set + +int value +int imstati() +errchk imstati + +begin + switch (param) { + case IM_BNDRYPIXVAL: + return (IM_OOBPIX(im)) + default: + value = imstati (im, param) + if (IS_INDEFI (value)) + return (INDEFR) + else + return (value) + } +end diff --git a/sys/imio/imstats.x b/sys/imio/imstats.x new file mode 100644 index 00000000..4deb5096 --- /dev/null +++ b/sys/imio/imstats.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include <imset.h> +include <imio.h> + +# IMSTATS -- Get an IMIO option of type string. + +procedure imstats (im, option, outstr, maxch) + +pointer im # image descriptor +int option # imset option being queried +char outstr[ARB] # output string +int maxch + +begin + switch (option) { + case IM_IMAGENAME: + call strcpy (IM_NAME(im), outstr, maxch) + default: + call imerr (IM_NAME(im), SYS_IMSTATUNKPAR) + } +end diff --git a/sys/imio/imt.x b/sys/imio/imt.x new file mode 100644 index 00000000..b508b0ae --- /dev/null +++ b/sys/imio/imt.x @@ -0,0 +1,305 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +.help imt +.nf ___________________________________________________________________________ +IMT -- Image template package. + +The image template package is based upon the filename template package, the +main difference being that the IMT package knows about the use of [] in image +names, e.g., for image sections or cluster indices. + + list = imtopenp (clparam) + + list = imtopen (template) + imtclose (list) + nchars|eof = imtgetim (list, image, maxch) + nchars|eof = imtrgetim (list, index, image, maxch) + len = imtlen (list) + imtrew (list) + +An image template consists of a comma delimited list of one or more patterns. +Each pattern consists of a filename template optionally followed by a cluster +index or image section. + + filename_template [image stuff] , ... + +In the simplest case a simple alphanumeric image or file name may be given. +Template expansion is carried out by parsing off the [] image stuff, calling +FNTOPNB to expand the filename template, and then appending the [] string to +each output filename returned by FNTGFNB. Multiple adjacent [] sequences are +permitted and are treated as one long string. + +The [ must be escaped to be included in the filename template. The escape +will be passed on, causing the [ to be passed through into the file output +filename. This prevents use of the [chars] character class notation in image +templates; the [] are either interpreted as part of the image specification, +or as part of the filename. +.endhelp _____________________________________________________________________ + +define SZ_FNT 16384 +define CH_DELIM 20B # used to flag image section + + +# IMTOPENP -- Open an image template obtained as the string value of a CL +# parameter. + +pointer procedure imtopenp (param) + +char param[ARB] # CL parameter with string value template +pointer sp, template, imt +pointer imtopen() +errchk clgstr + +begin + call smark (sp) + call salloc (template, SZ_FNT, TY_CHAR) + + call clgstr (param, Memc[template], SZ_FNT) + imt = imtopen (Memc[template]) + + call sfree (sp) + return (imt) +end + + +# IMTOPEN -- Open an image template. The filename template package is +# sophisticated enough to do all the necessary filename editing, etc., so all +# we need do is recast the image notation into a FNT edit operation, e.g., +# `*.imh[*,-*]' becomes `*.hhh%%?\[\*\,-\*]%', with the ? (CH_DELIM, actually +# an unprintable ascii code) being included to make it easy to locate the +# section string in the filenames returned by FNT. We then open the resultant +# template and perform the inverse mapping upon the filenames returned by FNT. + +pointer procedure imtopen (template) + +char template[ARB] # image template + +int sort, level, ip, ch +pointer sp, listp, fnt, op +define output {Memc[op]=$1;op=op+1} +int fntopnb(), strlen() + +begin + call smark (sp) + call salloc (fnt, max(strlen(template)*2, SZ_FNT), TY_CHAR) + + # Sorting is disabled as input and output templates, derived from the + # same database but with string editing used to modify the output list, + # may be sorted differently as sorting is performed upon the edited + # output list. + + sort = NO + + op = fnt + for (ip=1; template[ip] != EOS; ip=ip+1) { + ch = template[ip] + + if (ch == '[') { + if (ip > 1 && template[ip-1] == '!') { + # ![ -- Pass a [ to FNT (character class notation). + Memc[op-1] = '[' + + } else if (ip > 1 && template[ip-1] == '\\') { + # \[ -- The [ is part of the filename. Pass it on as an + # escape sequence to get by the FNT. + + output ('[') + + } else { + # [ -- Unescaped [. This marks the beginning of an image + # section sequence. Output `%%[...]%' and escape all + # pattern matching metacharacters until a comma template + # delimiter is encountered. Note that a comma within [] + # is not a template delimiter. + + output ('%') + output ('%') + output (CH_DELIM) + + level = 0 + for (; template[ip] != EOS; ip=ip+1) { + ch = template[ip] + if (ch == ',') { # , + if (level <= 0) + break # exit loop + else { + output ('\\') + output (ch) + } + } else if (ch == '[') { # [ + output ('\\') + output (ch) + level = level + 1 + } else if (ch == ']') { # ] + output (ch) + level = level - 1 + } else if (ch == '*') { # * + output ('\\') + output (ch) + } else # normal chars + output (ch) + } + output ('%') + ip = ip - 1 + } + + } else if (ch == '@') { + # List file reference. Output the CH_DELIM code before the @ + # to prevent further translations on the image section names + # returned from the list file, e.g., "CH_DELIM // @listfile". + + output (CH_DELIM) + output ('/') + output ('/') + output (ch) + + } else + output (ch) + } + + Memc[op] = EOS + listp = fntopnb (Memc[fnt], sort) + + call sfree (sp) + return (listp) +end + + +# IMTGETIM -- Get the next image name from the image template. FNT returns a +# filename with optional appended image section (preceded by the CH_DELIM +# character). Our job is to escape any [ in the filename part of the image +# name to avoid interpretation of these chars as image section characters by +# IMIO. The CH_DELIM is deleted and everything following is simply copied +# to the output. + +int procedure imtgetim (imt, outstr, maxch) + +pointer imt # image template descriptor +char outstr[ARB] # output string +int maxch # max chars out + +int nchars +pointer sp, buf +int fntgfnb(), imt_mapname() +errchk fntgfnb + +begin + call smark (sp) + call salloc (buf, SZ_PATHNAME, TY_CHAR) + + if (fntgfnb (imt, Memc[buf], SZ_PATHNAME) == EOF) { + outstr[1] = EOS + call sfree (sp) + return (EOF) + } + + nchars = imt_mapname (Memc[buf], outstr, maxch) + call sfree (sp) + return (nchars) +end + + +# IMTRGETIM -- Like imt_getim, but may be used to randomly access the image +# list. + +int procedure imtrgetim (imt, index, outstr, maxch) + +pointer imt # image template descriptor +int index # list element to be returned +char outstr[ARB] # output string +int maxch # max chars out + +int nchars +pointer sp, buf +int fntrfnb(), imt_mapname() +errchk fntrfnb + +begin + call smark (sp) + call salloc (buf, SZ_PATHNAME, TY_CHAR) + + if (fntrfnb (imt, index, Memc[buf], SZ_PATHNAME) == EOF) { + outstr[1] = EOS + call sfree (sp) + return (EOF) + } + + nchars = imt_mapname (Memc[buf], outstr, maxch) + call sfree (sp) + return (nchars) +end + + +# IMTLEN -- Return the number of image names in the expanded list. + +int procedure imtlen (imt) + +pointer imt # image template descriptor +int fntlenb() + +begin + return (fntlenb (imt)) +end + + +# IMTREW -- Rewind the expanded image list. + +procedure imtrew (imt) + +pointer imt # image template descriptor + +begin + call fntrewb (imt) +end + + +# IMTCLOSE -- Close an image template. + +procedure imtclose (imt) + +pointer imt # image template descriptor + +begin + call fntclsb (imt) +end + + +# IMT_MAPNAME -- Translate the string returned by FNT into an image +# specification suitable for input to IMIO. + +int procedure imt_mapname (fnt, outstr, maxch) + +char fnt[ARB] # FNT string +char outstr[ARB] # output string +int maxch + +int ip, op + +begin + op = 1 + for (ip=1; fnt[ip] != EOS; ip=ip+1) + if (fnt[ip] == '[') { + outstr[op] = '\\' + op = op + 1 + outstr[op] = '[' + op = op + 1 + + } else if (fnt[ip] == CH_DELIM) { + for (ip=ip+1; fnt[ip] != EOS; ip=ip+1) { + outstr[op] = fnt[ip] + op = op + 1 + if (op > maxch) + break + } + break + + } else { + outstr[op] = fnt[ip] + op = op + 1 + if (op > maxch) + break + } + + outstr[op] = EOS + return (op - 1) +end diff --git a/sys/imio/imt/README b/sys/imio/imt/README new file mode 100644 index 00000000..be232470 --- /dev/null +++ b/sys/imio/imt/README @@ -0,0 +1,280 @@ + + Enhanced Image List Template Package + + April 15, 2011 + + + The enhanced image list package provides new capabilities for handling +image lists, but remains backwards compatible with tasks currently using +the IMT interface. The enhancements allow for expansion of MEF files into +lists of extensions using the @-file operator, as well as selection of +images within more general lists by means of modifiers (e.g. a simple +expression such as the extname/extver or explicit extension number, or more +complex boolean expressions to allow selection by header keyword). In +addition, tables may now take the @-file operator to use a column +containing image references as an input list. + + +======================================================================== +TODO: + - Describe syntax for use with tables and selection by row values + - Describe remote image specification caching mechanism +======================================================================== + + + +Template Strings +---------------- + +The FNT template package supports the following forms of pattern strings: + + alpha, *.x, data* // .pix, [a-m]*, @list_file, nite%1%2%.1024.imh + +i.e. simple filenames, wildcard expansion in filenames, concatenation of +filenames, @files, substitution in filenames, or a comma-delimited list of +the above. The image template package (IMT) extends these patterns to +allow image names followed by a cluster index or image section in [] +brackets. These patterns remain unchanged in the new version of the +package to allow backward compatability with existing applications. Lists +of these types represent *explicit* collections of images, i.e. a +collection based on the image name (wildcards) or as a result of processing +by some task (e.g. expansion of an MEF file to create an input @-file of +expanded extension specifications). + + The enhanced version of the IMT package further abstracts the concept +of image collections to include data objects such as MEF files or tables +containing a list of image references that *implicitly* defines the list +(e.g. the expanded MEF extension specification or the complete column of +image references). Further, we allow this list (which might be quite +broad) to be refined using modifiers or selectors on the list and thus +dynamically create the list without requiring the use (and management) of +intermediate files. For example, + + + @file* expand all files beginning w/ 'file' + @file//".fits" append ".fits" to contents of 'file' + + @mef.fits expand all (image) extensions of an MEF file + @mef.fits[SCI] select SCI extensions from MEF file + @mef.fits[SCI,2][noinherit] select v2 SCI extns, add kernel param + @mef.fits[1-16x2] select range of extensions from MEF file + @mef.fits[+1-8] create a list of extensions for an MEF + + *.fits[1:100,1:100] append section to all FITS images + @@file[1:100,1:100] append section to expanded MEFs in 'file' + + *.fits[filter?='V'] select images w/ FILTER keyword containing 'V' + @*.fits[gain<3.0] select image extns where GAIN keyword < 3.0 + *.fits[filter?='V';gain<2.0] select using multiple OR's expressions + + +Template Syntax +--------------- + + The previous syntax and behavior of image templates is unchanged in +this version, new functionality is provided by (optional) new syntax now +supported in the template pattern string. Briefly, + + - wildcard filename expansion may now be applied to @-files + + - the use of an '@' operator is now permitted on MEF files. By + default, all image extensions in the file will be included in the + list, modifiers may be used to select specific extensions or to + indicate a range of extensions to be used. + + - the use of an '@@' operator to indicate expansion of the contents + of an @-file. For example, an @-file of MEF image names can be + expanded to list of all the file extensions using "@@file", whereas + just using "@file" would list the names of the MEF files as before. + + - modifier expressions enclosed in square brackets may be appended + to an image template string (or @-file) to either constrain the + list (e.g. only a range of MEF extensions, only images with a certain + keyword value, etc) or to append extra information to the image + specification (e.g. to add an image section to all images in the + list). Multiple modifier expressions may be used + + + The allowed syntax for a template string can be described roughly in +the following way: + + + [@@ | @] <file> [extname] [<expr>;...] [<ikparams>] [<section>] + [@@ | @] <file> [extname,extver][<expr>;...] [<ikparams>] [<section>] + [@@ | @] <file> [index_range] [<expr>;...] [<ikparams>] [<section>] + + <-------- selectors -------> <------ modifiers -----> + + The <file> specification may be the name of a file, and image, or a +table. The behavior of the @-file and @@-file operators will depend on +the type of <file> but the @-file usage remains backward compatible when +used with text files. + + The use of a modifier/selection on an MEF file will automatically +trigger expansion of the extensions in the image and so an '@' operator is +not strictly required, however only those extensions matching the selection +expression will be present in the final image list. Note that the use of +index ranges and extname/extver selectors are mutually exclusive, selector +expressions may be added to either. + + +@-file Operations +----------------- + + The @-file operator is unchanged from previous versions when used with +text files of image names. Modifier/selector expressions however can now +be applied to the contents of the @-file to select from the list only those +images that match the selector expression, or to augment the name in the +list with an additional image syntax such as a section or kernel parameters. + + +@@-file Operations +------------------ + + The @@-file operator is new syntax meant to allow the contents of an +@-file to be expanded automaticaly, e.g. as if there were an @-file of +@-file names. Primarily this can be used to create a list of MEF image +names in which an @-file would return the names of the MEF, while the +@@-file syntax could be used to expand each MEF into individual extension +specifications. + + +Extension Indices +----------------- + + The [index_range] modifier may be used to specify an explicit set of +extensions to be used. Index ranges are specified as a comma-delimited +list of strings specifying individual range segments as described in the +RANGES help page. + + The use of a '+' operator before an index range indicates the range +list should be expanded without checking that the extension exists in the +MEF itself. Otherwise, only those extensions present in the MEF will be +included in the list. + + +Selection Expressions +--------------------- + + Selection expressions may be used to restrict a template list to only +those images that match some boolean expression, e.g. to provide for +selection based on a header keyword value. Expressions follow the same +guidelines as in the HSELECT task 'expr' parameter (see the help page +for details). Multiple expressions may be specified if they are separated +by a semicolon however they are evaluated as a single expression of +OR'd values rather than as individual expressions. This is significant +when considering that expressions may contain keywords not present in +all images being checked, for instance + + *.fits[filter?='V';gain<3.0] + +would evaluate as if the expression had been written + + (filter?='V' || gain < 3.0) + +If a particular image lacks either the 'filter' or 'gain' keyword the +entire expression will evaluate to false because of an error even if one +of the two clauses would otherwise have been true. + +[NOTE: This behavior will be changed in a future version.] + + + +Image Sections +-------------- + Image sections may be added to an image specification by adding a +separate modifier string. The section will be added once selection of +the list by the selector expressions is complete. An example of where +this might be used is in automatically specifying the bias section for +all images in a list, e.g. + + @mef.fits[1:128,*] all extensions in the image + @mef.fits[1-16x2][1:128,*] only 'left' amplifiers of a mosaic + @mef.fits[2-16x2][1024:1128,*] only 'right' amplifiers of a mosaic + m31*.fits[345:528,200:300] same section in all registered images + +No check is made that the image section is valid for the given image. + + +Kernel Parameters +----------------- + + A comma-delimited list of image kernel parameters may be added to any +image specification by adding the keywords to a separate modifier. For +example, + @mef.fits[1-8][noinherit,padline=30] + +would expand the file 'mef.fits' to include extensions 1 thru 8 and add the +kernel parameters, generating a list such as + + mef.fits[1][noinherit,padline=30] + mef.fits[2][noinherit,padline=30] + : : : : + mef.fits[8][noinherit,padline=30] + +No check is made to verify that the image kernel keywords are appropriate +for the image type. Supplying an incorrect kernel parameter will likely +result in the task throwing an error when opening the image. + + + +-------------------------------------------------------------------------------- + +Appendix 1: Examples + + file + file* + @file + @file* + + @file[2] extension + @file[SCI] extname + @file[SCI,2] extname+extver + + @file[2][noinherit] extension + ikiparams + @file[SCI][noinherit] extname + ikiparams + @file[SCI,2][noinherit] extname+extver + ikiparams + + @file[2][1:20,2:30] extension + section + @file[SCI][1:20,2:30] extname + section + @file[SCI,2][1:20,2:30] extname+extver + section + + @file[2][noinherit][1:20,2:30] extension + ikiparams + section + @file[SCI][noinherit][1:20,2:30] extname + ikiparams + section + @file[SCI,2][noinherit][1:20,2:30] extname+extver + ikiparams + section + + @file[noinherit] ikiparams + @file[noinherit][1:123,2:234] ikiparams + sections + + @file[1:123,2:234] sections + + @file[1:123,2:234] sections + + mef*.fits[filter?='V'] selection expression + mef*.fits[filter?='V';filter?='B'] selection expressions (OR) + mef*.fits[filter?='V'||filter?='B'] selection expressions (OR) + mef*.fits[gain>0.5&&gain<2.0] selection expressions (AND) + + Expressions will evaluate to 'false' if there is an error such as + "keyword not found", meaning that no images will match when one or + more keywords may not be present. Best to use a comma-delimited list + in this case. + + Concatenation + + @file // foo append + @file* // foo append wildcards + @file // [2] append modifiers + + foo // @file prepend + foo // @file* prepend wildcards + foo // @file[2] prepend modifiers + + Prior Behavior: + + foo // bar.fits ==> foobar.fits + foo.fits // bar ==> foobar.fits + + foo // @file1 ==> foosif1.fits,foomef1.fits + @file1 // bar ==> sif1foo.fits,mef1foo.fits + diff --git a/sys/imio/imt/fxf.h b/sys/imio/imt/fxf.h new file mode 100644 index 00000000..c4e6188b --- /dev/null +++ b/sys/imio/imt/fxf.h @@ -0,0 +1,172 @@ +# FITS.H -- IKI/FITS internal definitions. + +define FITS_ORIGIN "NOAO-IRAF FITS Image Kernel July 2003" + +define FITS_LENEXTN 4 # max length imagefile extension +define SZ_DATATYPE 16 # size of datatype string (eg "REAL*4") +define SZ_EXTTYPE 20 # size of exttype string (eg BINTABLE) +define SZ_KEYWORD 8 # size of a FITS keyword +define SZ_EXTRASPACE (81*32) # extra space for new cards in header +define DEF_PHULINES 0 # initial allocation for PHU +define DEF_EHULINES 0 # initial allocation for EHU +define DEF_PADLINES 0 # initial value for extra lines in HU +define DEF_PLMAXLEN 32768 # default max PLIO encoded line length +define DEF_PLDEPTH 0 # default PLIO mask depth + +define FITS_BLOCK_BYTES 2880 # FITS logical block length (bytes) +define FITS_BLOCK_CHARS 1440 # FITS logical block length (spp chars) +define FITS_STARTVALUE 10 # first column of value field +define FITS_ENDVALUE 30 # last column of value field +define FITS_SZVALSTR 21 # nchars in value string +define LEN_CARD 80 # length of FITS card. +define LEN_UACARD 81 # size of a Userarea line. +define LEN_OBJECT 63 # maximum length of a FITS string value +define LEN_FORMAT 40 # maximum length of a TFORM value +define NO_KEYW -1 # indicates no keyword is present. + +define MAX_OFFSETS 100 # max number of offsets per cache entry. +define MAX_CACHE 60 # max number of cache entries. +define DEF_CACHE 10 # default number of cache entries. + +define DEF_HDREXTN "fits" # default header file extension +define ENV_FKINIT "fkinit" # FITS kernel initialization + +define DEF_ISOCUTOVER 0 # date when ISO format dates kick in +define ENV_ISOCUTOVER "isodates" # environment override for default + +define FITS_BYTE 8 # Bits in a FITS byte +define FITS_SHORT 16 # Bits in a FITS short +define FITS_LONG 32 # Bits in a FITS long +define FITS_REAL -32 # 32 Bits FITS IEEE float representation +define FITS_DOUBLE -64 # 64 Bits FITS IEEE double representation + +define COL_VALUE 11 # Starting column for parameter values +define NDEC_REAL 7 # Precision of real +define NDEC_DOUBLE 14 # Precision of double + +define FITS_LEN_CHAR (((($1) + 1439)/1440)* 1440) + +# Extension subtypes. +define FK_PLIO 1 + +# Mapping of FITS Keywords to IRAF image header. All unrecognized keywords +# are stored here. + +#define UNKNOWN Memc[($1+IMU-1)*SZ_MII_INT+1] +define UNKNOWN Memc[($1+IMU-1)*SZ_STRUCT+1] + + +# FITS image descriptor, used internally by the FITS kernel. The required +# header parameters are maintained in this descriptor, everything else is +# simply copied into the user area of the IMIO descriptor. + +define LEN_FITDES 500 +define LEN_FITBASE 400 + +define FIT_ACMODE Memi[$1] # image access mode +define FIT_PFD Memi[$1+1] # pixel file descriptor +define FIT_PIXOFF Memi[$1+2] # pixel offset +define FIT_TOTPIX Memi[$1+3] # size of image in pixfile, chars +define FIT_IO Memi[$1+4] # FITS I/O channel +define FIT_ZCNV Memi[$1+5] # set if on-the-fly conversion needed +define FIT_IOSTAT Memi[$1+6] # i/o status for zfio routines +define FIT_TFORMP Memi[$1+7] # TFORM keyword value pointer +define FIT_TTYPEP Memi[$1+8] # TTYPE keyword value pointer +define FIT_TFIELDS Memi[$1+9] # number of fields in binary table +define FIT_PCOUNT Memi[$1+10] # PCOUNT keyword value + # extra space +define FIT_BSCALE Memd[P2D($1+16)] +define FIT_BZERO Memd[P2D($1+18)] +define FIT_BITPIX Memi[$1+20] # bits per pixel +define FIT_NAXIS Memi[$1+21] # number of axes in image +define FIT_LENAXIS Memi[$1+22+$2-1]# 35:41 = [7] max +define FIT_ZBYTES Memi[$1+30] # Status value for FIT_ZCNV mode +define FIT_HFD Memi[$1+31] # Header file descriptor +define FIT_PIXTYPE Memi[$1+32] +define FIT_CACHEHDR Memi[$1+33] # Cached main header unit's address. +define FIT_CACHEHLEN Memi[$1+34] # Lenght of the above. +define FIT_IM Memi[$1+35] # Has the 'im' descriptor value +define FIT_GROUP Memi[$1+36] +define FIT_NEWIMAGE Memi[$1+37] # Newimage flag +define FIT_HDRPTR Memi[$1+38] # Header data Xtension pointer +define FIT_PIXPTR Memi[$1+39] # Pixel data Xtension pointer +define FIT_NUMOFFS Memi[$1+40] # Number of offsets in cache header. +define FIT_EOFSIZE Memi[$1+41] # Size in char of file before append. +define FIT_XTENSION Memi[$1+42] # Yes, if an Xtension has been read. +define FIT_INHERIT Memi[$1+43] # INHERIT header keyword value. +define FIT_EXTVER Memi[$1+44] # EXTVER value (integer only) +define FIT_EXPAND Memi[$1+45] # Expand the header? +define FIT_MIN Memr[P2R($1+46)]# Minimum pixel value +define FIT_MAX Memr[P2R($1+47)]# Maximum pixel value +define FIT_MTIME Meml[$1+48] # Time of last mod. for FITS unit +define FIT_SVNANR Memr[P2R($1+49)] +define FIT_SVNAND Memd[P2D($1+50)] +define FIT_SVMAPRIN Memi[$1+52] +define FIT_SVMAPROUT Memi[$1+53] +define FIT_SVMAPDIN Memi[$1+54] +define FIT_SVMAPDOUT Memi[$1+55] +define FIT_EXTEND Memi[$1+56] # FITS extend keyword +define FIT_PLMAXLEN Memi[$1+57] # PLIO maximum linelen + # extra space +define FIT_EXTTYPE Memc[P2C($1+70)] # extension type +define FIT_FILENAME Memc[P2C($1+110)] # FILENAME value +define FIT_EXTNAME Memc[P2C($1+150)] # EXTNAME value +define FIT_DATATYPE Memc[P2C($1+190)] # datatype string +define FIT_TITLE Memc[P2C($1+230)] # title string +define FIT_OBJECT Memc[P2C($1+270)] # object string +define FIT_EXTSTYPE Memc[P2C($1+310)] # FITS extension subtype + # extra space + +# The FKS terms carry the fkinit or kernel section arguments. +define FKS_APPEND Memi[$1+400] # YES, NO append an extension +define FKS_INHERIT Memi[$1+401] # YES, NO inherit the main header +define FKS_OVERWRITE Memi[$1+402] # YES, NO overwrite an extension +define FKS_DUPNAME Memi[$1+403] # YES, NO allow duplicated EXTNAME +define FKS_EXTVER Memi[$1+404] # YES, NO allow duplicated EXTNAME +define FKS_EXPAND Memi[$1+405] # YES, NO expand the header +define FKS_PHULINES Memi[$1+406] # Allocated lines in PHU +define FKS_EHULINES Memi[$1+407] # Allocated lines in EHU +define FKS_PADLINES Memi[$1+408] # Additional lines for HU +define FKS_NEWFILE Memi[$1+409] # YES, NO force newfile +define FKS_CACHESIZE Memi[$1+410] # size of header cache +define FKS_SUBTYPE Memi[$1+411] # BINTABLE subtype +define FKS_EXTNAME Memc[P2C($1+412)] # EXTNAME value + # extra space + + +# Reserved FITS keywords known to this code. + +define FK_KEYWORDS "|bitpix|datatype|end|naxis|naxisn|simple|bscale|bzero\ +|origin|iraf-tlm|filename|extend|irafname|irafmax|irafmin|datamax\ +|datamin|xtension|object|pcount|extname|extver|nextend|inherit\ +|zcmptype|tform|ttype|tfields|date|" + +define KW_BITPIX 1 +define KW_DATATYPE 2 +define KW_END 3 +define KW_NAXIS 4 +define KW_NAXISN 5 +define KW_SIMPLE 6 +define KW_BSCALE 7 +define KW_BZERO 8 +define KW_ORIGIN 9 +define KW_IRAFTLM 10 +define KW_FILENAME 11 +define KW_EXTEND 12 +define KW_IRAFNAME 13 +define KW_IRAFMAX 14 +define KW_IRAFMIN 15 +define KW_DATAMAX 16 +define KW_DATAMIN 17 +define KW_XTENSION 18 +define KW_OBJECT 19 +define KW_PCOUNT 20 +define KW_EXTNAME 21 +define KW_EXTVER 22 +define KW_NEXTEND 23 +define KW_INHERIT 24 +define KW_ZCMPTYPE 25 +define KW_TFORM 26 +define KW_TTYPE 27 +define KW_TFIELDS 28 +define KW_DATE 29 diff --git a/sys/imio/imt/imt.x b/sys/imio/imt/imt.x new file mode 100644 index 00000000..64e1441c --- /dev/null +++ b/sys/imio/imt/imt.x @@ -0,0 +1,342 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +.help imt +.nf ___________________________________________________________________________ +IMT -- Image template package. + +The image template package is based upon the filename template package, the +main difference being that the IMT package knows about the use of [] in image +names, e.g., for image sections or cluster indices. + + list = imtopenp (clparam) + + list = imtopen (template) + imtclose (list) + nchars|eof = imtgetim (list, image, maxch) + nchars|eof = imtrgetim (list, index, image, maxch) + len = imtlen (list) + imtrew (list) + +An image template consists of a comma delimited list of one or more patterns. +Each pattern consists of a filename template optionally followed by a cluster +index or image section. + + filename_template [image stuff] , ... + +In the simplest case a simple alphanumeric image or file name may be given. +Template expansion is carried out by parsing off the [] image stuff, calling +FNTOPNB to expand the filename template, and then appending the [] string to +each output filename returned by FNTGFNB. Multiple adjacent [] sequences are +permitted and are treated as one long string. + +The [ must be escaped to be included in the filename template. The escape +will be passed on, causing the [ to be passed through into the file output +filename. This prevents use of the [chars] character class notation in image +templates; the [] are either interpreted as part of the image specification, +or as part of the filename. +.endhelp _____________________________________________________________________ + +define SZ_FNT 16384 +define CH_DELIM 20B # used to flag image section + + +# IMTOPENP -- Open an image template obtained as the string value of a CL +# parameter. + +pointer procedure imtopenp (param) + +char param[ARB] # CL parameter with string value template +pointer sp, template, imt +pointer imtopen() +errchk clgstr + +begin + call smark (sp) + call salloc (template, SZ_FNT, TY_CHAR) + + call clgstr (param, Memc[template], SZ_FNT) + imt = imtopen (Memc[template]) + + call sfree (sp) + return (imt) +end + + +# IMTOPEN -- Open an image template. The filename template package is +# sophisticated enough to do all the necessary filename editing, etc., so all +# we need do is recast the image notation into a FNT edit operation, e.g., +# `*.imh[*,-*]' becomes `*.hhh%%?\[\*\,-\*]%', with the ? (CH_DELIM, actually +# an unprintable ascii code) being included to make it easy to locate the +# section string in the filenames returned by FNT. We then open the resultant +# template and perform the inverse mapping upon the filenames returned by FNT. + +pointer procedure imtopen (template) + +char template[ARB] # image template + +int sort, level, ip, ch +pointer sp, listp, fnt, op +define output {Memc[op]=$1;op=op+1} + +int fntopnb(), strlen() +pointer imxopen() +bool envgetb() + +begin + # The interface is unchanged as far as the applications are + # concerned, but we'll branch here to the enhanced list processing + # if it is available. + + if (envgetb ("use_vo") && envgetb ("use_new_imt")) + return (imxopen (template)) + + + call smark (sp) + call salloc (fnt, max(strlen(template)*2, SZ_FNT), TY_CHAR) + + # Sorting is disabled as input and output templates, derived from the + # same database but with string editing used to modify the output list, + # may be sorted differently as sorting is performed upon the edited + # output list. + + sort = NO + + op = fnt + for (ip=1; template[ip] != EOS; ip=ip+1) { + ch = template[ip] + + if (ch == '[') { + if (ip > 1 && template[ip-1] == '!') { + # ![ -- Pass a [ to FNT (character class notation). + Memc[op-1] = '[' + + } else if (ip > 1 && template[ip-1] == '\\') { + # \[ -- The [ is part of the filename. Pass it on as an + # escape sequence to get by the FNT. + + output ('[') + + } else { + # [ -- Unescaped [. This marks the beginning of an image + # section sequence. Output `%%[...]%' and escape all + # pattern matching metacharacters until a comma template + # delimiter is encountered. Note that a comma within [] + # is not a template delimiter. + + output ('%') + output ('%') + output (CH_DELIM) + + level = 0 + for (; template[ip] != EOS; ip=ip+1) { + ch = template[ip] + if (ch == ',') { # , + if (level <= 0) + break # exit loop + else { + output ('\\') + output (ch) + } + } else if (ch == '[') { # [ + output ('\\') + output (ch) + level = level + 1 + } else if (ch == ']') { # ] + output (ch) + level = level - 1 + } else if (ch == '*') { # * + output ('\\') + output (ch) + } else # normal chars + output (ch) + } + output ('%') + ip = ip - 1 + } + + } else if (ch == '@') { + # List file reference. Output the CH_DELIM code before the @ + # to prevent further translations on the image section names + # returned from the list file, e.g., "CH_DELIM // @listfile". + + output (CH_DELIM) + output ('/') + output ('/') + output (ch) + + } else + output (ch) + } + + Memc[op] = EOS + + listp = fntopnb (Memc[fnt], sort) + + call sfree (sp) + return (listp) +end + + +# IMTGETIM -- Get the next image name from the image template. FNT returns a +# filename with optional appended image section (preceded by the CH_DELIM +# character). Our job is to escape any [ in the filename part of the image +# name to avoid interpretation of these chars as image section characters by +# IMIO. The CH_DELIM is deleted and everything following is simply copied +# to the output. + +int procedure imtgetim (imt, outstr, maxch) + +pointer imt # image template descriptor +char outstr[ARB] # output string +int maxch # max chars out + +int nchars +pointer sp, buf +int fntgfnb(), imt_mapname() +errchk fntgfnb + +begin + call smark (sp) + call salloc (buf, SZ_PATHNAME, TY_CHAR) + + if (fntgfnb (imt, Memc[buf], SZ_PATHNAME) == EOF) { + outstr[1] = EOS + call sfree (sp) + return (EOF) + } + + nchars = imt_mapname (Memc[buf], outstr, maxch) + call sfree (sp) + return (nchars) +end + + +# IMTRGETIM -- Like imt_getim, but may be used to randomly access the image +# list. + +int procedure imtrgetim (imt, index, outstr, maxch) + +pointer imt # image template descriptor +int index # list element to be returned +char outstr[ARB] # output string +int maxch # max chars out + +int nchars +pointer sp, buf +int fntrfnb(), imt_mapname() +errchk fntrfnb + +begin + call smark (sp) + call salloc (buf, SZ_PATHNAME, TY_CHAR) + + if (fntrfnb (imt, index, Memc[buf], SZ_PATHNAME) == EOF) { + outstr[1] = EOS + call sfree (sp) + return (EOF) + } + + nchars = imt_mapname (Memc[buf], outstr, maxch) + call sfree (sp) + return (nchars) +end + + +# IMTLEN -- Return the number of image names in the expanded list. + +int procedure imtlen (imt) + +pointer imt # image template descriptor +int fntlenb() + +begin + return (fntlenb (imt)) +end + + +# IMTREW -- Rewind the expanded image list. + +procedure imtrew (imt) + +pointer imt # image template descriptor + +begin + call fntrewb (imt) +end + + +# IMTCLOSE -- Close an image template. + +procedure imtclose (imt) + +pointer imt # image template descriptor + +begin + call fntclsb (imt) +end + + +# IMT_MAPNAME -- Translate the string returned by FNT into an image +# specification suitable for input to IMIO. + +int procedure imt_mapname (fnt, outstr, maxch) + +char fnt[ARB] # FNT string +char outstr[ARB] # output string +int maxch + +int ip, op +char url[SZ_PATHNAME], cfname[SZ_PATHNAME] + +int strncmp(), strlen() +bool envgetb() + +begin + # Check for a URL-encoded string. + + if (strncmp ("http:", fnt, 5) == 0) { + call aclrc (url, SZ_PATHNAME) + call sprintf (url, SZ_PATHNAME, "http://%s") + call pargstr (fnt[6]) + + call fcadd ("cache$", url, "", cfname, SZ_PATHNAME) + call strcpy (cfname, outstr, SZ_PATHNAME) + return (strlen (cfname)) + } + + op = 1 + for (ip=1; fnt[ip] != EOS; ip=ip+1) { + if (fnt[ip] == '[') { + outstr[op] = '\\' + op = op + 1 + outstr[op] = '[' + op = op + 1 + + } else if (fnt[ip] == CH_DELIM) { + for (ip=ip+1; fnt[ip] != EOS; ip=ip+1) { + outstr[op] = fnt[ip] + op = op + 1 + if (op > maxch) + break + } + break + + } else { + outstr[op] = fnt[ip] + op = op + 1 + if (op > maxch) + break + } + } + outstr[op] = EOS + + # FIXME + if (envgetb ("vo_prefetch") && strncmp (outstr, "cache", 5) == 0) { +# call sprintf (cfname, SZ_LINE, "%s.fits") + call sprintf (cfname, SZ_LINE, "%s") + call pargstr (outstr) + call fcwait ("cache$", cfname) + } + + return (op - 1) +end diff --git a/sys/imio/imt/imx.h b/sys/imio/imt/imx.h new file mode 100644 index 00000000..362e146f --- /dev/null +++ b/sys/imio/imt/imx.h @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + + +define SZ_FNT 32768 +define CH_DELIM 20B # used to flag image section + +define IMT_FILE 0 # file list +define IMT_IMAGE 1 # image list +define IMT_TABLE 2 # table list (ascii file) +define IMT_VOTABLE 3 # table list (XML file) +define IMT_URL 4 # file URL +define IMT_DIR 5 # directory + +define IMT_OUTPUTS "|none|list|file|" # expansion options +define IMTY_NONE 1 # No output +define IMTY_LIST 2 # List output +define IMTY_FILE 3 # File output + +define SZ_RANGE 100 # Size of extension range list +define SZ_LISTOUT 16384 # Size of extension output list + +define FIRST 1 # Default starting range +define LAST MAX_INT # Default ending range +define STEP 1 # Default step +define EOLIST -1 # End of list + diff --git a/sys/imio/imt/imx.x b/sys/imio/imt/imx.x new file mode 100644 index 00000000..ba3f7bc8 --- /dev/null +++ b/sys/imio/imt/imx.x @@ -0,0 +1,242 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include <syserr.h> +include <ctype.h> +include "imx.h" + +define DEBUG FALSE + + +# IMXOPEN -- Open an image template using the enhanced expansion +# capabilities. This procedure is simply the entry point to the imtopen() +# method in the standard IMT interface. + +pointer procedure imxopen (template) + +char template[ARB] # image template + +int i, sort, level, ip, ch, expand, nchars, nimages, index, type +int max_fnt, fnt_len, len, flen +pointer listp, intmp, fnt, op, exp +char lfile[SZ_LINE], lexpr[SZ_LINE], likparams[SZ_LINE], lsec[SZ_LINE] +char lindex[SZ_LINE], lextname[SZ_LINE], lextver[SZ_LINE], elem[SZ_LINE] + +pointer imx_preproc (), imx_imexpand (), imx_fexpand () +pointer imx_texpand (), imx_dexpand () +int imx_filetype (), imx_parse (), imx_get_element () +int fntopnb (), strlen (), strsearch() +int sum, fntlenb() +bool envgetb() + +define output {Memc[op]=$1;op=op+1} +define escape {output('\\');output($1)} + +begin + # Pre-process the input template. + intmp = imx_preproc (template) + + if (DEBUG) { + call eprintf ("template: '%s'\npreproc: '%s'\n\n") + call pargstr (template) + call pargstr (Memc[intmp]) + } + + + fnt_len = 0 # initialize + max_fnt = SZ_FNT + call calloc (fnt, max_fnt, TY_CHAR) + + # Sorting is disabled as input and output templates, derived from the + # same database but with string editing used to modify the output list, + # may be sorted differently as sorting is performed upon the edited + # output list. + + sort = NO + + op = fnt + ip = intmp + + for (ip=intmp; Memc[ip] != EOS; ip=ip+1) { + ch = Memc[ip] + + if (ch == '[') { + if (ip > 1 && Memc[ip-1] == '!') { + # ![ -- Pass a [ to FNT (character class notation). + Memc[op-1] = '[' + + } else if (ip > 1 && Memc[ip-1] == '\\') { + # \[ -- The [ is part of the filename. Pass it on as an + # escape sequence to get by the FNT. + + output ('[') + + } else { + # [ -- Unescaped [. This marks the beginning of an image + # section sequence. Output `%%[...]%' and escape all + # pattern matching metacharacters until a comma template + # delimiter is encountered. Note that a comma within [] + # is not a template delimiter. + + output ('%') + output ('%') + output (CH_DELIM) + + level = 0 + for (; Memc[ip] != EOS; ip=ip+1) { + ch = Memc[ip] + if (ch == ',') { # , + if (level <= 0) + break # exit loop + else { + escape (ch) + } + } else if (ch == '[') { # [ + escape (ch) + level = level + 1 + } else if (ch == ']') { # ] + output (ch) + level = level - 1 + } else if (ch == '*') { # * + escape (ch) + } else # normal chars + output (ch) + } + output ('%') + ip = ip - 1 + } + + } else if (ch == '@') { + # List file reference. Output the CH_DELIM code before the @ + # to prevent further translations on the image section names + # returned from the list file, e.g., "CH_DELIM // @listfile". + + # See if we're asking to expand the contents of the file, + # e.g. as in "@@listfile" where 'listfile' contains MEFs + # or tables we later expand. + expand = NO + if (Memc[ip+1] == '@') + expand = YES + + # Break out the listfile from the filtering expression. + + index = 1 + nchars = imx_get_element (Memc[ip], index, elem, SZ_LINE) + ip = ip + strlen(elem) - 1 + + nchars = imx_parse (elem, lfile, lindex, lextname, + lextver, lexpr, lsec, likparams, SZ_LINE) + + if (DEBUG) { + call eprintf ("imtopen: lfile='%s' lexpr='%s' ip='%s'\n") + call pargstr (lfile) + call pargstr (lexpr) + call pargstr (Memc[ip]) + } + + + exp = NULL + type = imx_filetype (lfile) + switch (type) { + case IMT_IMAGE: + exp = imx_imexpand (lfile, lexpr, lindex, lextname, lextver, + likparams, lsec, nimages) + + case IMT_TABLE: + case IMT_VOTABLE: + exp = imx_texpand (lfile, type, lexpr, lindex, "", nimages) + + case IMT_FILE: + if (strsearch (lfile, "//") > 0) { + call calloc (exp, SZ_FNAME, TY_CHAR) + call strcpy (lfile, Memc[exp], SZ_FNAME) + nimages = 1 + + } else if (lfile[1] == '@' && strsearch(lfile, "//") == 0) { + exp = imx_fexpand (lfile[2], lexpr, lindex, lextname, + lextver, likparams, lsec, nimages) +# if (nimages > 0) { +# output (CH_DELIM); output ('/'); output ('/') +# } + + } else { + call calloc (exp, SZ_FNAME, TY_CHAR) + call strcpy (lfile, Memc[exp], SZ_FNAME) + nimages = 1 + } + + case IMT_DIR: + exp = imx_dexpand (lfile, lexpr, lindex, lextname, lextver, + likparams, lsec, nimages) + } + + if (DEBUG) { + call eprintf ("expand: exp='%s' len=%d nim=%d\n") + call pargstr (Memc[exp]) + call pargi (strlen(Memc[exp])) + call pargi (nimages) + } + + + # Copy to the output template string. + len = strlen (Memc[exp]) + if (nimages > 0) { + if ((fnt_len + len) >= max_fnt) { + max_fnt = max_fnt + len + 1 + if (fnt != NULL) + call realloc (fnt, max_fnt, TY_CHAR) + else + call calloc (fnt, max_fnt, TY_CHAR) + op = fnt + if (fnt_len > 0) + op = fnt + strlen (Memc[fnt]) + } + for (i=0; i < len; i=i+1) + output (Memc[exp+i]) + Memc[op+1] = EOS + fnt_len = fnt_len + strlen (Memc[exp]) + } + + if (exp != NULL) + call mfree (exp, TY_CHAR) + nimages = 0 + + } else + output (ch) + } + output ('\0') + Memc[op] = EOS + + + # Clean up the expanded template string in case there were selection + # filters that rejected images and we have extra commas in the string. + len = strlen (Memc[fnt]) + if (Memc[fnt+len-1] == ',') { # kill trailing commas + for (ip=fnt+len-1; Memc[ip] == ',' && ip >= fnt; ip=ip-1) + Memc[ip] = '\0' + } + if (Memc[fnt] == ',') { + for (ip=fnt; Memc[ip] == ','; ) # skip leading commas + ip = ip + 1 + for (op=fnt; Memc[ip] != EOS; ip=ip+1) { + Memc[op] = Memc[ip] + op = op + 1 + } + Memc[op] = '\0' + } + + if (DEBUG) { + call eprintf ("imxopen: fnt='%s'\n") + call pargstr (Memc[fnt]) + } + + + # Open the template string using the filename list. + listp = fntopnb (Memc[fnt], sort) + + # Clean up. + call mfree (fnt, TY_CHAR) + call mfree (intmp, TY_CHAR) + + return (listp) +end diff --git a/sys/imio/imt/imxbreakout.x b/sys/imio/imt/imxbreakout.x new file mode 100644 index 00000000..57a92b8a --- /dev/null +++ b/sys/imio/imt/imxbreakout.x @@ -0,0 +1,233 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <ctype.h> + + +# IMX_BREAKOUT -- Break out the filename template from the filtering +# expression in the list item. Our input value is a single item in the +# template list, we'll logically separate image parameters, section strings +# and extension values from expressions that might be used in filtering. + +int procedure imx_breakout (item, expand, fname, expr, sec, ikparams, maxch) + +char item[ARB] #i template string ptr +int expand #i expanding contents? +char fname[ARB] #o list filename +char expr[ARB] #o filtering expression +char sec[ARB] #o section string +char ikparams[ARB] #o image kernel params +int maxch #i max chars in fname and expr + +char ch, str[SZ_LINE], sifname[SZ_LINE] +int nchars, ip, op +bool is_sif + +bool imx_issection(), imx_sifmatch() +int stridx() + +define next_str_ 99 + +begin + call aclrc (fname, maxch) + call aclrc (expr, maxch) + call aclrc (sec, maxch) + + # At the start the ip points to the '@' in the template string. + # Skip ahead to the start of the filename template string. + ip = 1 + if (expand == YES) + ip = ip + 1 + + # Copy out the filename template up to the EOS, a '[' to indicate + # the start of a filter expression, or a comma indicating the next + # item in the list. + ch = item[ip] + for (op=1; ch != EOS; op=op+1) { + fname[op] = ch + + ch = item[ip+1] + if (ch == ',' || ch == EOS) + return (ip-1) # next list item, no filter expr + else if (ch == '[') + break # break to get the filter expr + + ip = ip + 1 + } + + + # Get the string up to the closing ']' char. +next_str_ + ip = ip + 2 + ch = item[ip] + call aclrc (str, SZ_LINE) + for (op=1; ch != EOS; op=op+1) { + str[op] = ch + + ip = ip + 1 + ch = item[ip] + if (ch == ']') + break # break to get the filter expr + } + + if (imx_issection (str)) { + call strcpy (str, sec, SZ_LINE) + } else { + if (expr[1] != EOS) { + call strcat (",", expr, SZ_LINE) + call strcat (str, expr, SZ_LINE) + } else + call strcpy (str, expr, SZ_LINE) + } + + if (item[ip+1] != EOS) + goto next_str_ + + call imx_ikparams (expr, ikparams, SZ_LINE) + + # If we've found both a section and an expression, check that the + # section isn't being confused with an index list. + #if (sec[1] != EOS && expr[1] != EOS) { + # if (!is_sif && stridx (':', sec) == 0) { + # call strcat (",", expr, SZ_LINE) + # call strcat (sec, expr, SZ_LINE) + # } + #} + + if (sec[1] != EOS) { + call aclrc (sifname, SZ_LINE) + call sprintf (sifname, SZ_LINE, "%s[1][%s]") + if (fname[1] == '@') + call pargstr (fname[2]) + else + call pargstr (fname) + call pargstr (sec) + } else { + call strcpy (fname, sifname, SZ_LINE) + } + is_sif = imx_sifmatch (sifname, "yes") + + nchars = ip - 1 + return (nchars) +end + + +# IMX_ISSECTION -- Determine if the string is an image section. +# +# Note: There is a possible ambiguity here where using an image section +# that represents a single pixel (e.g. foo.fits[100,100]) which might also +# be a list of image extensions. + +bool procedure imx_issection (str) + +char str[ARB] # string to be checked + +int ip, stridxs() + +begin + for (ip=1; str[ip] != EOS; ip=ip+1) { + if (IS_ALPHA(str[ip]) || stridxs ("x()<>?", str) > 0) + return (FALSE) + } + + # Test for a range list, e.g. "[1-5]" + if (stridxs ("-,", str) > 0 && stridxs (":*", str) == 0) + return (FALSE); + + # Test for a section that flips axes, e.g. "[-*,*]" + if (stridxs ("-*:,", str) > 0) + return (TRUE); + + return (FALSE) +end + + +# IMX_IKPARMS -- Break out the image kernel params from the template list +# expression string. + +procedure imx_ikparams (expr, ikparams, maxch) + +char expr[ARB] # expression string to modify +char ikparams[ARB] # extracted image kernel params +int maxch # max size of output strings + +int ip, op, nexpr, niki +char ch, in[SZ_LINE], sub[SZ_LINE] + +bool imx_isikparam() + +begin + call aclrc (in, SZ_LINE) # initialize + call strcpy (expr, in, SZ_LINE) + nexpr = 0 + niki = 0 + + call aclrc (expr, maxch) + call aclrc (ikparams, maxch) + for (ip=1; in[ip] != EOS; ip=ip+1) { + # Copy out the sub expression, i.e. up to the comma or EOS. + call aclrc (sub, SZ_LINE) + op = 1 + while (in[ip] != EOS && in[ip] != ',' && in[ip] != ';') { + sub[op] = in[ip] + ip = ip + 1 + op = op + 1 + } + ch = in[ip] + + if (imx_isikparam (sub)) { + if (niki > 0) + call strcat (",", ikparams, maxch) + call strcat (sub, ikparams, maxch) + niki = niki + 1 + + } else { + if (nexpr > 0) + call strcat (",", expr, maxch) + call strcat (sub, expr, maxch) + nexpr = nexpr + 1 + } + + if (ch == EOS) + break + } +end + + +# IMX_ISIKPARAM -- See whether the substring refers to an image kernel param. + +bool procedure imx_isikparam (str) + +char str[ARB] # string to check + +int strncmp() + +begin + if (strncmp (str, "extname", 7) == 0 || strncmp (str, "extver", 6) == 0) + return (TRUE) + + # Check for the "no" versions of selected keywords. + else if (strncmp (str, "no", 2) == 0) { + if ((strncmp (str[3], "append", 4) == 0) || + (strncmp (str[3], "inherit", 4) == 0) || + (strncmp (str[3], "overwrite", 4) == 0) || + (strncmp (str[3], "dupname", 4) == 0) || + (strncmp (str[3], "expand", 4) == 0)) + return (TRUE) + } + + # Other kernel keywords. + if (strncmp (str, "inherit", 4) == 0 || + strncmp (str, "overwrite", 4) == 0 || + strncmp (str, "dupname", 4) == 0 || + strncmp (str, "append", 4) == 0 || + strncmp (str, "noappend", 4) == 0 || + strncmp (str, "type", 4) == 0 || + strncmp (str, "expand", 4) == 0 || + strncmp (str, "phulines", 4) == 0 || + strncmp (str, "ehulines", 4) == 0 || + strncmp (str, "padlines", 4) == 0 || + strncmp (str, "cachesize", 4) == 0) + return (TRUE) + + return (FALSE) +end diff --git a/sys/imio/imt/imxescape.x b/sys/imio/imt/imxescape.x new file mode 100644 index 00000000..92750ab7 --- /dev/null +++ b/sys/imio/imt/imxescape.x @@ -0,0 +1,74 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "imx.h" + + +# IMX_ESCAPE -- Return a pointer to the composed file name, escaping parts +# as needed. + +pointer procedure imx_escape (in, index, extname, extver, ikparams, + section, expr, maxch) + +char in[ARB] #I File image name (without kernel or image sec) +char index[ARB] #I Range list of extension indexes +char extname[ARB] #I Pattern for extension names +char extver[ARB] #I Range list of extension versions +char ikparams[ARB] #I Image kernel parameters +char section[ARB] #I Image section +char expr[ARB] #I Selection expression +int maxch #I Print errors? + +pointer out, op +int i, len, level +char ch, peek, prev +bool init_esc + +int strlen() + +define output {Memc[op]=$1;op=op+1} +define escape {output('\\');output($1)} + +begin + len = max (SZ_LINE, strlen (in)) + call calloc (out, max (SZ_LINE, (4*len)), TY_CHAR) + + op = out + level = 0 + + init_esc = false + for (i=1; i <= len; i=i+1) { + prev = in[max(1,i)] + ch = in[i] + peek = in[i+1] + + if (ch == EOS) + break; + if (ch == '[') { + if (prev != ']' && !init_esc) { + output ('%') + output ('%') + output (CH_DELIM) + init_esc = true + } + escape (ch) + level = level + 1 + } else if (ch == ']') { + output (ch) + if (peek != '[') # closing delim + output ('%') + level = level - 1 + } else if (ch == ',') { + if (level > 0) + output('\\') + if (level == 0) + init_esc = false + output (ch) + } else if (ch == '*') + escape (ch) + else + output (ch) + } + output (EOS) + + return (out) +end diff --git a/sys/imio/imt/imxexpand.x b/sys/imio/imt/imxexpand.x new file mode 100644 index 00000000..72efb17c --- /dev/null +++ b/sys/imio/imt/imxexpand.x @@ -0,0 +1,1287 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include <syserr.h> +include <imhdr.h> +include <imset.h> +include <mach.h> +include <fio.h> +include <finfo.h> +include <ctype.h> +include <diropen.h> + +include "imx.h" +include <votParse_spp.h> + + +define SZ_BUF 8192 # name buffer string + + +# IMX_IMEXPAND -- Expand a template of FITS files into a list of image +# extensions. + +pointer procedure imx_imexpand (input, expr, index, extname, extver, ikparams, + section, nimages) + +char input[ARB] # List of ME file names +char expr[ARB] # Filtering expression +char index[ARB] # Range list of extension indexes +char extname[ARB] # Patterns for extension names +char extver[ARB] # Range list of extension versions +char ikparams[ARB] # Image kernel parameters +char section[ARB] # Image section parameters +int nimages # Number of output images + +int lindex # List index number? +int lname # List extension name? +int lver # List extension version? + +pointer in, out # Pointer to output string +pointer sp, sif, image, listout +int list, len, maxch + +int imx_extns(), strlen(), fntgfnb(), fntlenb() +pointer imx_escape() +bool imx_sifmatch() + +begin + call smark (sp) + call salloc (in, SZ_FNAME, TY_CHAR) + call salloc (image, SZ_FNAME, TY_CHAR) + + + lindex = YES # expansion parameters + lname = NO + lver = NO + out = NULL + len = 0 + nimages = 0 + maxch = SZ_LISTOUT + + call aclrc (Memc[in], SZ_FNAME) + if (input[1] == '@') + call strcpy (input[2], Memc[in], SZ_FNAME) + else + call strcpy (input, Memc[in], SZ_FNAME) + + # Get the list. + list = imx_extns (Memc[in], "IMAGE", index, extname, extver, + lindex, lname, lver, ikparams, section, expr, YES) + + if (list == NULL || fntlenb (list) == 0) { + call calloc (out, SZ_LINE, TY_CHAR) + call strcpy (Memc[in], Memc[out], SZ_LINE) + if (section[1] != EOS) { + call strcat ("\\[", Memc[out], maxch) + call strcat (section, Memc[out], maxch) + call strcat ("]", Memc[out], maxch) + } + if (ikparams[1] != EOS) { + call strcat ("\\[", Memc[out], maxch) + call strcat (ikparams, Memc[out], maxch) + call strcat ("]", Memc[out], maxch) + } + + if (index[1] == EOS && imx_sifmatch (Memc[out], expr)) { + nimages = 1 + sif = imx_escape (Memc[out], index, extname, extver, ikparams, + section, expr, maxch) + } else + call calloc (sif, SZ_LINE, TY_CHAR) + call mfree (out, TY_CHAR) + return (sif) + } + + # Format the output and set the number of images. + call calloc (listout, maxch, TY_CHAR) + iferr { + while (fntgfnb (list, Memc[image], SZ_FNAME) != EOF) { + nimages = nimages + 1 + if (nimages > 1) { + call strcat (",", Memc[listout], maxch) + len = len + 1 + } + if ((len + strlen (Memc[image])) >= maxch) { + maxch = maxch + SZ_LISTOUT + call realloc (listout, maxch, TY_CHAR) + } + + call strcat (Memc[image], Memc[listout], maxch) + len = len + strlen (Memc[image]) + +# if (section[1] != EOS) { +# call strcat ("[", Memc[listout], maxch) +# call strcat (section, Memc[listout], maxch) +# call strcat ("]", Memc[listout], maxch) +# len = len + strlen (section) + 2 +# } + } + + # Escape the output image specification in a form that is correct + # for the filename template interface. + + out = imx_escape (Memc[listout], index, extname, extver, ikparams, + section, expr, maxch) + + } then { + call fntclsb (list) + call sfree (sp) + call error (1, "Output list format is too long") + } + call fntclsb (list) + call sfree (sp) + + return (out) +end + + +# IMX_FEXPAND -- Expand a template of files into a list of images names. + +pointer procedure imx_fexpand (input, expr, index, extname, extver, ikparams, + section, nimages) + +char input[ARB] # List of ME file names +char expr[ARB] # Filtering expression +char index[ARB] # Range list of extension indexes +char extname[ARB] # Patterns for extension names +char extver[ARB] # Range list of extension versions +char ikparams[ARB] # Image kernel parameters +char section[ARB] # Image section parameters +int nimages # Number of output images + +pointer sp, name, exp, lexp, nexp +int fd, ip, op, len, elen, nlines, nims, maxch, nchars, level +bool do_proc +char line[SZ_LINE], buf[SZ_LINE], ch + +define output {buf[op]=$1;op=op+1} + + +int open(), getline(), strlen(), stridx() +pointer imx_imexpand() + +begin + iferr (fd = open (input, READ_ONLY, TEXT_FILE)) { + call error (1, "Cannot open @file") + return (NULL) + } + + call smark (sp) + call salloc (name, SZ_PATHNAME, TY_CHAR) + + maxch = SZ_FNT + call calloc (exp, maxch, TY_CHAR) + call aclrc (Memc[exp], maxch) + +#call eprintf ( +# "fexpand: index='%s' name='%s' ver='%s' sec='%s' ik='%s' expr='%s'\n") +# call pargstr (index) ; call pargstr (extname) ; call pargstr (extver) ; +# call pargstr (section) ; call pargstr (ikparams) ; call pargstr (expr) + + nlines = 0 + nchars = 0 + nimages = 0 + + while (getline (fd, line) > 0) { + len = strlen (line) + line[len] = EOS # kill newline + nlines = nlines + 1 + + call aclrc (Memc[name], SZ_PATHNAME) + call sprintf (Memc[name], SZ_PATHNAME, "@%s") + call pargstr (line) + + lexp = 0 + do_proc = (index[1]!=EOS || section[1]!=EOS || + expr[1]!=EOS || extname[1]!=EOS) + + if (input[1] == '@' || do_proc) { + + # We're either being asked to expand what is presumably a + # image name in the form of an @@file input, or else we've + # added image sections, expressions, etc where the correct + # output specification is the expanded image name. + + lexp = imx_imexpand (Memc[name], expr, index, extname, extver, + ikparams, section, nims) + + elen = 0 + if (lexp != NULL && Memc[lexp] != EOS) + elen = strlen (Memc[lexp]) + + # Reallocate space is the output name if needed. + #if ((nchars + elen) >= (maxch - SZ_FNAME)) { + if ((nchars + elen) >= maxch) { + call calloc (nexp, maxch + SZ_FNT, TY_CHAR) + call amovc (Memc[exp], Memc[nexp], maxch) + call mfree (exp, TY_CHAR) + maxch = maxch + SZ_FNT + exp = nexp + } + + # Create a comma-delimited list. + if (nlines > 1) + call strcat (",", Memc[exp], maxch) + if (lexp != NULL && Memc[lexp] != EOS) { + call strcat (Memc[lexp], Memc[exp], maxch) + nchars = nchars + elen + 1 + } + nimages = nimages + nims + } else { + if (nlines > 1) { + call strcat (",", Memc[exp], maxch) + nchars = nchars + 1 + } + if (stridx ('[', line) != 0) { + call aclrc (buf, SZ_LINE) + op = 1 + for (ip=1; line[ip] != EOS; ip=ip+1) { + if (line[ip] == '[') { + output ('%') + output ('%') + output (CH_DELIM) + + level = 0 + for (; line[ip] != EOS; ip=ip+1) { + ch = line[ip] + if (ch == ',') { # , + if (level <= 0) + break # exit loop + else { + output ('\\') + output (ch) + } + } else if (ch == '[') { # [ + output ('\\') + output (ch) + level = level + 1 + } else if (ch == ']') { # ] + output (ch) + level = level - 1 + } else if (ch == '*') { # * + output ('\\') + output (ch) + } else # normal chars + output (ch) + } + output ('%') + ip = ip - 1 + + break + } + buf[op] = line[ip] + op = op + 1 + } + call strcat (buf, Memc[exp], maxch) + nchars = nchars + strlen (buf) + + } else { + call strcat (line, Memc[exp], maxch) + nchars = nchars + strlen (line) + } + + nchars = nchars + len + 1 + nimages = nimages + 1 + + # Reallocate space is the output name if needed. + + if ((nchars + SZ_LINE) >= maxch) { + call calloc (nexp, maxch + SZ_FNT, TY_CHAR) + call amovc (Memc[exp], Memc[nexp], maxch) + call mfree (exp, TY_CHAR) + maxch = maxch + SZ_FNT + exp = nexp + } + } + call mfree (lexp, TY_CHAR) + } + + call close (fd) # clean up + call sfree (sp) + + return (exp) +end + + +# IMX_TEXPAND -- Expand a template of tables into a list of images. + +pointer procedure imx_texpand (input, type, expr, index, fmt, nimages) + +char input[ARB] # Input table name +int type # Table type +char expr[ARB] # Filtering expression +char index[ARB] # Range list of table rows +char fmt[ARB] # Requested file format +int nimages # Number of output images + +char fname[SZ_PATHNAME] # File name to open +char ofname[SZ_PATHNAME] +pointer sp, exp, nodename +int ip, vfd, status, delim + +pointer imx_votable(), imx_table() +int vfnopen(), vfnmapu(), strncmp(), ki_gnode() + +begin + call smark (sp) + call salloc (nodename, SZ_PATHNAME, TY_CHAR) + + exp = NULL # initialize values + nimages = 0 + + # Get the base filename without the '@' prefix. + if (input[1] == '@') + call strcpy (input[2], fname, SZ_PATHNAME) + else + call strcpy (input, fname, SZ_PATHNAME) + + # Map input VFN to OSFN. + ip = 1 + if (strncmp (fname, "http://", 7) == 0) { + call strcpy (fname, ofname, SZ_PATHNAME) + } else { + vfd = vfnopen (fname, READ_ONLY) + status = vfnmapu (vfd, ofname, SZ_PATHNAME) + call vfnclose (vfd, VFN_NOUPDATE) + + # If the file resides on the local node strip the node name, + # returning a legal host system filename as the result. + if (ki_gnode (ofname, Memc[nodename], delim) == 0) + ip = delim + 1 + } + + + # Now process the file. For a VOTable we parse the file and + # extract the acref columns as cached image names, for ascii + # tables we read the URLs directly but likewise returned the + # cache name. + + if (type == IMT_TABLE) + exp = imx_table (ofname[ip], index, nimages) + else if (type == IMT_VOTABLE) + exp = imx_votable (ofname[ip], expr, index, fmt, nimages) + + call sfree (sp) + return (exp) +end + + +# IMX_DEXPAND -- Expand a directory into a list of images. + +pointer procedure imx_dexpand (input, expr, index, extname, extver, ikparams, + sec, nimages) + +char input[ARB] # List of MEF file names +char expr[ARB] # Filtering expression +char index[ARB] # Index range +char extname[ARB] # Extension name +char extver[ARB] # Extension version +char ikparams[ARB] # IKI parameters +char sec[ARB] # Image section +int nimages # Number of output images + +pointer sp, exp, nodename, imname, listout +int dir, len, llen, nim, ip, delim, vfd, status, maxlen +char dirname[SZ_PATHNAME], ofname[SZ_PATHNAME], pdir[SZ_PATHNAME] +char fpath[SZ_PATHNAME], fname[SZ_PATHNAME] + +pointer imx_imexpand () +int vfnopen(), vfnmapu(), ki_gnode(), imx_filetype() +int strlen(), diropen(), isdirectory(), getline() + +begin + call smark (sp) + call salloc (nodename, SZ_PATHNAME, TY_CHAR) + + # Get the base filename without the '@' prefix. + if (input[1] == '@') { + if (input[2] == '@') + call strcpy (input[3], dirname, SZ_PATHNAME) + else + call strcpy (input[2], dirname, SZ_PATHNAME) + } else + call strcpy (input, dirname, SZ_PATHNAME) + + # Remove trailing '/' or '$' from dir + len = strlen (dirname) + if (dirname[len] == '/') + dirname[len] = EOS + + # Map input VFN to OSFN. + ip = 1 + vfd = vfnopen (dirname, READ_ONLY) + status = vfnmapu (vfd, ofname, SZ_PATHNAME) + call vfnclose (vfd, VFN_NOUPDATE) + + # If the file resides on the local node strip the node name, + # returning a legal host system filename as the result. + if (ki_gnode (ofname, Memc[nodename], delim) == 0) + ip = delim + 1 + + call sfree (sp) + + # Otherwise, read through the directory and remove the contents. + dir = diropen (ofname, SKIP_HIDDEN_FILES) + + maxlen = SZ_LISTOUT + call calloc (listout, SZ_LISTOUT, TY_CHAR) + llen = 0 + while (getline (dir, fname) != EOF) { + len = strlen (fname) + fname[len] = '\0' + + len = strlen (ofname) + if (ofname[len] == '/' || ofname[len] == '$') + call sprintf (fpath, SZ_PATHNAME, "%s%s") + else + call sprintf (fpath, SZ_PATHNAME, "%s/%s") + call pargstr (dirname) + call pargstr (fname) + + llen = llen + strlen (fpath) + + # We only test plain files, skip directories. + if (isdirectory (fpath, pdir, SZ_PATHNAME) > 0) + next + + if (imx_filetype (fpath) == IMT_IMAGE) { + + if (input[2] == '@') + imname = imx_imexpand (fpath, expr, index, extname, extver, + ikparams, sec, nim) + else { + call calloc (imname, SZ_PATHNAME, TY_CHAR) + call strcpy (fpath, Memc[imname], SZ_PATHNAME) + } + + if (imname != NULL && Memc[imname] != EOS) { + nimages = nimages + 1 + + if (nimages > 1) { + call strcat (",", Memc[listout], maxlen) + llen = llen + 1 + } + if ((llen + strlen (Memc[imname])) >= maxlen) { + maxlen = maxlen + SZ_LISTOUT + call realloc (listout, maxlen, TY_CHAR) + } + + call strcat (Memc[imname], Memc[listout], maxlen) + llen = llen + strlen (Memc[imname]) + + if (sec[1] != EOS) { + call strcat ("[", Memc[listout], maxlen) + call strcat (sec, Memc[listout], maxlen) + call strcat ("]", Memc[listout], maxlen) + llen = llen + strlen (sec) + 2 + } + + if (imname != NULL) + call mfree (imname, TY_CHAR) + } + } + } + + return (listout) +end + + +# IMX_FETCH -- Fetch the urls from the list. + +procedure imx_fetch (urls, istemp) + +char urls[ARB] #I file of URLS to download +bool istemp #i is input file temporary? + +char osfn[SZ_PATHNAME] +char url_osfn[SZ_PATHNAME] + +int n, envgets() +char nthreads[SZ_FNAME] + +begin + # Get the host pathname of the cache directory. + call fmapfn ("cache$", osfn, SZ_PATHNAME) + call strupk (osfn, osfn, SZ_PATHNAME) + + call fmapfn (urls, url_osfn, SZ_PATHNAME) + call strupk (url_osfn, url_osfn, SZ_PATHNAME) + + n = envgets ("vo_nthreads", nthreads, SZ_FNAME) + + # voget -B -C -D cache$ -b url -N <N> [-t] <infile> + if (istemp) { + call vx_voget (10, "-B", "-C", "-D", osfn, "-b", "url", + "-N", nthreads, "-t", url_osfn) + } else { + call vx_voget (10, "-B", "-C", "-D", osfn, "-b", "url", + "-N", nthreads, "-B", url_osfn) + } +end + + +# IMX_VOTABLE -- Read a VOTable, extracting the column of access references +# as the image list. + +pointer procedure imx_votable (input, expr, index, fmt, nimages) + +char input[ARB] # List of ME file names +char expr[ARB] # Filtering expression +char index[ARB] # Range list of table rows +char fmt[ARB] # Requested file format +int nimages # Number of output images + +pointer vot, exp, ranges +int nranges, tfd +char tfile[SZ_PATHNAME] + +int open() +int imx_decode_ranges() +pointer imx_votselect(), votinit() +bool envgetb() + +begin + # Create a temp file for the parsed access references. + call mktemp ("tmp$vot", tfile, SZ_PATHNAME) + iferr (tfd = open (tfile, NEW_FILE, TEXT_FILE)) { + nimages = 0 + return (NULL) + } + + # Expand the index string into a range structure. + if (index[1] != EOS) { + call calloc (ranges, 3 * SZ_RANGE, TY_INT) + if (imx_decode_ranges (index, Memi[ranges], SZ_RANGE, + nranges, YES) == ERR) { + call eprintf ("error parsing range '%s'\n") + call pargstr (index) + } + } else + ranges = NULL + + # Initialize the VOT struct and parse the table. + vot = votinit (input) + + # Select the column from the VOTable with the access reference. + exp = imx_votselect (vot, tfd, fmt, ranges, nimages) + + call mfree (ranges, TY_INT) + call votclose (vot) # close the files + call close (tfd) + + # Close the temp file and pre-fetch the data if needed. + if (envgetb ("vo_prefetch")) + call imx_fetch (tfile, true) + + return (exp) +end + + +# IMX_VOTSELECT -- Select the access reference column. + +pointer procedure imx_votselect (vot, fd, fmt, ranges, nimages) + +pointer vot #i VOTable struct pointer +int fd #i filename of selected rows +char fmt[ARB] #i file format +pointer ranges #i ranges struct pointer +int nimages #o no. selected images + +pointer exp +int col, len, clen, maxlen +char acref_ucd[SZ_FNAME], imfmt[SZ_FNAME], ucd_col[SZ_FNAME] +char acref[SZ_LINE], ucd[SZ_FNAME], buf[SZ_LINE], cfname[SZ_PATHNAME] +int i, rownum, field, acref_col, acfmt_col + +int strcmp(), strsearch(), strlen(), vx_getNext() +bool imx_in_range() + +begin + # Figure out which table column we want. Note that we assume there + # is only one <RESOURCE> element. The caller may pass in a specific + # column to be used, otherwise look for for the named UCD. + + col = 0 # FIXME + call aclrc (ucd_col, SZ_FNAME) # FIXME + call strcpy ("fits", imfmt, SZ_FNAME) # FIXME + + call aclrc (acref_ucd, SZ_FNAME) + if (col > 0) { + acref_col = col + } else { + if (ucd_col[1] != EOS) + call strcpy (ucd_col, acref_ucd, SZ_FNAME) + else + call strcpy (DEF_ACREF_UCD, acref_ucd, SZ_FNAME) + + # Find the access reference column number. + i = 0 + for (field=VOT_FIELD(vot); field > 0; field=vx_getNext (field)) { + call aclrc (ucd, SZ_FNAME) + call vx_getAttr (field, "ucd", ucd, SZ_FNAME) + if (strcmp (ucd, acref_ucd) == 0) { + acref_col = i + } else if (strcmp (ucd, DEF_FORMAT_UCD) == 0) + acfmt_col = i + i = i + 1 + } + } + + maxlen = SZ_BUF + call calloc (exp, maxlen, TY_CHAR) + + # Download the files. + for (i=0; i < VOT_NROWS(vot); i=i+1) { + call vx_getTableCell (VOT_TDATA(vot), i, acfmt_col, imfmt, SZ_FNAME) + + if (fmt[1] == EOS || (fmt[1] != EOS && strsearch(imfmt, fmt) > 0)) { + call vx_getTableCell (VOT_TDATA(vot), i, acref_col, + acref, SZ_LINE) + + # Do the row selection based on the index string. + rownum = i + 1 + if (ranges != NULL && ! imx_in_range (Memi[ranges], rownum)) + next + + # Generate a unique cache filename based on the URL. + call fcname ("cache$", acref, "url", cfname, SZ_PATHNAME) + + # Append the cache name to the output string. Reallocate the + # string pointer if needed. + clen = strlen (cfname) + if ((len + clen) >= maxlen) { + maxlen = maxlen + SZ_BUF + call realloc (exp, maxlen, TY_CHAR) + } + len = len + clen + + if (nimages == 0) { + call strcpy (cfname, Memc[exp], maxlen) + } else { + call strcat (",", Memc[exp], maxlen) + call strcat (cfname, Memc[exp], maxlen) + } + call aclrc (buf, SZ_LINE) + + # Write the URL to the download file. + call fprintf (fd, "%s\n") + call pargstr (acref) + + nimages = nimages + 1 + } + } + + return (exp) +end + + +# IMX_TABLE -- Read an ASCII text table of URLs and create the list +# of files to process. We apply the list index to do row selection +# and return a list of cached filenames. + +pointer procedure imx_table (input, index, nimages) + +char input[ARB] # List of ME file names +char index[ARB] # Range list of table rows +int nimages # Number of output images + +pointer exp, ranges +int rownum, nranges, fd, len, clen, maxlen +char buf[SZ_LINE], cfname[SZ_PATHNAME] + +int open(), getline(), strlen() +int imx_decode_ranges() +bool imx_in_range(), envgetb() + +begin + call aclrc (buf, SZ_LINE) + iferr (fd = open (input, READ_ONLY, TEXT_FILE)) + call syserr (SYS_FOPEN) + + maxlen = SZ_BUF + call calloc (exp, maxlen, TY_CHAR) + + call calloc (ranges, 3 * SZ_RANGE, TY_INT) + if (index[1] != EOS) { + if (imx_decode_ranges (index, Memi[ranges], SZ_RANGE, + nranges, YES) == ERR) { + call eprintf ("error parsing range '%s'\n") + call pargstr (index) + } + } + + len = 0 + nimages = 0 + rownum = 0 + while (getline (fd, buf) != EOF) { + + # Skip comments and blank lines. + if (buf[1] == '\n' || buf[1] == '#') + next + else + rownum = rownum + 1 + + # Do the row selection based on the index string. + if (index[1] != EOS && ! imx_in_range (Memi[ranges], rownum)) + next + + # Generate a unique cache filename based on the URL. + call fcname ("cache$", buf, "url", cfname, SZ_PATHNAME) + + # Append the cache name to the output string. Reallocate the + # string pointer if needed. + clen = strlen (cfname) + if ((len + clen) >= maxlen) { + maxlen = maxlen + SZ_BUF + call realloc (exp, maxlen, TY_CHAR) + } + len = len + clen + + if (nimages == 0) { + call strcpy (cfname, Memc[exp], maxlen) + } else { + call strcat (",", Memc[exp], maxlen) + call strcat (cfname, Memc[exp], maxlen) + } + call aclrc (buf, SZ_LINE) + + nimages = nimages + 1 + } + + call mfree (ranges, TY_INT) + call close (fd) + + if (envgetb ("vo_prefetch")) + call imx_fetch (input, false) + + return (exp) +end + + +# IMX_EXTNS -- Expand a template of ME files into a list of image extensions. + +int procedure imx_extns (files, exttype, index, extname, extver, + lindex, lname, lver, ikparams, section, expr, err) + +char files[ARB] #I List of ME files +char exttype[ARB] #I Extension type string +char index[ARB] #I Range list of extension indexes +char extname[ARB] #I Patterns for extension names +char extver[ARB] #I Range list of extension versions +int lindex #I List index number? +int lname #I List extension name? +int lver #I List extension version? +char expr[ARB] #I Selection expression +char ikparams[ARB] #I Image kernel parameters +char section[ARB] #I Image section parameters +int err #I Print errors? +int list #O Image list + +int i, fd, create +pointer sp, temp, fname, imname, sec, rindex, rextver, ikp, str +int fntopnb(), fntgfnb() +int imx_decode_ranges(), nowhite(), open() +errchk open, imx_extn, delete + +begin + call smark (sp) + call salloc (temp, SZ_FNAME, TY_CHAR) + call salloc (fname, SZ_FNAME, TY_CHAR) + call salloc (imname, SZ_FNAME, TY_CHAR) + call salloc (sec, SZ_FNAME, TY_CHAR) + call salloc (ikp, SZ_LINE, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Expand parameters. + list = fntopnb (files, NO) + call salloc (rindex, 3*SZ_RANGE, TY_INT) + if (imx_decode_ranges (index, Memi[rindex], SZ_RANGE, i, create) == ERR) + call error (1, "Bad index range list") + + rextver = NULL + if (nowhite (extver, Memc[str], SZ_LINE) > 0) { + call salloc (rextver, 3*SZ_RANGE, TY_INT) + if (imx_decode_ranges (Memc[str], Memi[rextver], SZ_RANGE, + i, create) == ERR) + call error (1, "Bad extension version range list") + } + + call aclrc (Memc[ikp], SZ_LINE) + i = nowhite (ikparams, Memc[ikp], SZ_LINE) + + # Expand ME files into list of image extensions in a temp file. + call mktemp ("@tmp$iraf", Memc[temp], SZ_FNAME) + fd = open (Memc[temp+1], NEW_FILE, TEXT_FILE) + while (fntgfnb (list, Memc[fname], SZ_FNAME) != EOF) { + call imgimage (Memc[fname], Memc[imname], SZ_FNAME) + call imgsection (Memc[fname], Memc[sec], SZ_FNAME) + + call imx_extn (fd, Memc[imname], exttype, expr, rindex, extname, + rextver, lindex, lname, lver, Memc[ikp], section, + create, err) + } + call fntclsb (list) + call close (fd) + + # Return list. + list = fntopnb (Memc[temp], NO) + call delete (Memc[temp+1]) + call sfree (sp) + + return (list) +end + + +# IMX_EXTN -- Expand a single ME file into a list of image extensions. +# The image extensions are written to the input file descriptor. + +procedure imx_extn (fd, fname, exttype, expr, index, extname, extver, lindex, + lname, lver, ikparams, section, create, err) + +int fd #I File descriptor for list +char fname[SZ_FNAME] #I File image name (without kernel or image sec) +char exttype[SZ_FNAME] #I File extension type +char expr[ARB] #I Selection expression +pointer index #I Range list of extension indexes +char extname[ARB] #I Pattern for extension names +pointer extver #I Range list of extension versions +int lindex #I List index number? +int lname #I List extension name? +int lver #I List extension version? +char ikparams[ARB] #I Image kernel parameters +char section[ARB] #I Image section +int create #I Create names from index range? +int err #I Print errors? + +pointer sp, image, name, type, str, im +int i, j, ver + +pointer immap() +int imx_get_next_number(), errcode(), imgeti(), stridxs(), strcmp() +bool imx_in_range(), imx_extmatch(), imx_matchexpr(), imx_sifmatch() + +begin + call smark (sp) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (type, SZ_FNAME, TY_CHAR) + call salloc (name, SZ_LINE, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + i = -1 + while (imx_get_next_number (Memi[index], i) != EOF) { + j = stridxs ("[", fname) + if (j > 0) { + if (i > 0) + break + call strcpy (fname, Memc[image], SZ_FNAME) + } else { + call sprintf (Memc[image], SZ_FNAME, "%s[%d]") + call pargstr (fname) + call pargi (i) + } + + if (section[1] != EOS) { + call strcat ("[", Memc[image], SZ_FNAME) + call strcat (section, Memc[image], SZ_FNAME) + call strcat ("]", Memc[image], SZ_FNAME) + } + + # We know the extension doesn't exist, generate the name. + if (create == YES) { + call fprintf (fd, "%s") + call pargstr (Memc[image]) + if (section[1] != EOS) { + call fprintf (fd, "[%s]") + call pargstr (section) + } + call fprintf (fd, "\n") + next + } + + + iferr (im = immap (Memc[image], READ_ONLY, 0)) { + switch (errcode()) { + case SYS_FXFRFEOF: + if (i == 1) { + if (extname[1] == EOS && imx_sifmatch (fname, expr)) { + call fprintf (fd, "%s\n") + call pargstr (fname) + next + } else + break + } + break + case SYS_IKIEXTN: + next + case SYS_IKIOPEN: + switch (i) { + case 0: + next + case 1: + if (err == YES) + call erract (EA_WARN) + break + default: + break + } + default: + call erract (EA_ERROR) + } + } + + + # Check the extension type. [NOT USED] + if (exttype[1] != EOS) { + iferr (call imgstr (im, "xtension", Memc[type], SZ_FNAME)) + Memc[type] = EOS + if (Memc[type] != EOS && strcmp (Memc[type], exttype) != 0) { + call imunmap (im) + next + } + } + +#call eprintf("imx_extn: name='%s' ver='%s' expr='%s' sec='%s' iki='%s'\n") +# call pargstr (extname) ; call pargstr (Memc[extver]) ; +# call pargstr (expr) ; call pargstr (section) ; +# call pargstr (ikparams) ; + + # Check the extension name. + if (extname[1] != EOS) { + iferr (call imgstr (im, "extname", Memc[name], SZ_FNAME)) + Memc[name] = EOS + if (!imx_extmatch (Memc[name], extname)) { + call imunmap (im) + next + } + } + + # Check the extension version. + if (extver != NULL) { + iferr (ver = imgeti (im, "extver")) { + call imunmap (im) + next + } + if (!imx_in_range (Memi[extver], ver)) { + call imunmap (im) + next + } + } + + # Check the selection expression. + if (expr[1] != EOS) { + if (!imx_matchexpr (im, expr)) { + call imunmap (im) + next + } + } + + + # Set the extension name and version. + if (lname == YES) { + iferr (call imgstr (im, "extname", Memc[name], SZ_LINE)) + Memc[name] = EOS + } else + Memc[name] = EOS + if (lver == YES) { + iferr (ver = imgeti (im, "extver")) + ver = INDEFI + } else + ver = INDEFI + + # Write the image name. + call fprintf (fd, fname) + if (j == 0) { + if (lindex == YES || (Memc[name] == EOS && IS_INDEFI(ver))) { + call fprintf (fd, "[%d]") + call pargi (i) + } + if (Memc[name] != EOS) { + call fprintf (fd, "[%s") + call pargstr (Memc[name]) + if (!IS_INDEFI(ver)) { + call fprintf (fd, ",%d") + call pargi (ver) + } + if (ikparams[1] != EOS) { + call fprintf (fd, ",%s") + call pargstr (ikparams) + } + call fprintf (fd, "]") + } else if (!IS_INDEFI(ver)) { + call fprintf (fd, "[extver=%d") + call pargi (ver) + if (ikparams[1] != EOS) { + call fprintf (fd, ",%s") + call pargstr (ikparams) + } + call fprintf (fd, "]") + } else if (ikparams[1] != EOS) { + call fprintf (fd, "[%s]%%") + call pargstr (ikparams) + } + } + if (section[1] != EOS) { + call fprintf (fd, "[%s]") + call pargstr (section) + } + call fprintf (fd, "\n") + + call imunmap (im) + } + + call sfree (sp) +end + + +# IMX_DECODE_RANGES -- Parse a string containing a list of integer numbers or +# ranges, delimited by either spaces or commas. Return as output a list +# of ranges defining a list of numbers, and the count of list numbers. +# Range limits must be positive nonnegative integers. ERR is returned as +# the function value if a conversion error occurs. The list of ranges is +# delimited by EOLIST. + +int procedure imx_decode_ranges (range_string, ranges, max_ranges, + nvalues, create) + +char range_string[ARB] # Range string to be decoded +int ranges[3, max_ranges] # Range array +int max_ranges # Maximum number of ranges +int nvalues # The number of values in the ranges +int create # generate range string? + +int ip, nrange, first, last, step, ctoi() + +begin + create = NO + if (range_string[1] == '+') { + ip = 2 + create = YES + } else + ip = 1 + nvalues = 0 + + do nrange = 1, max_ranges - 1 { + # Defaults to all nonnegative integers + first = FIRST + last = LAST + step = STEP + + # Skip delimiters + while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') + ip = ip + 1 + + # Get first limit. + # Must be a number, '-', 'x', or EOS. If not return ERR. + if (range_string[ip] == EOS) { # end of list + if (nrange == 1) { + # Null string defaults + ranges[1, 1] = first + ranges[2, 1] = last + ranges[3, 1] = step + ranges[1, 2] = EOLIST + nvalues = MAX_INT + return (OK) + } else { + ranges[1, nrange] = EOLIST + return (OK) + } + } else if (range_string[ip] == '-') + ; + else if (range_string[ip] == 'x') + ; + else if (IS_DIGIT(range_string[ip])) { # ,n.. + if (ctoi (range_string, ip, first) == 0) + return (ERR) + } else + return (ERR) + + # Skip delimiters + while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') + ip = ip + 1 + + # Get last limit + # Must be '-', or 'x' otherwise last = first. + if (range_string[ip] == 'x') + ; + else if (range_string[ip] == '-') { + ip = ip + 1 + while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') + ip = ip + 1 + if (range_string[ip] == EOS) + ; + else if (IS_DIGIT(range_string[ip])) { + if (ctoi (range_string, ip, last) == 0) + return (ERR) + } else if (range_string[ip] == 'x') + ; + else + return (ERR) + } else + last = first + + # Skip delimiters + while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') + ip = ip + 1 + + # Get step. + # Must be 'x' or assume default step. + if (range_string[ip] == 'x') { + ip = ip + 1 + while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') + ip = ip + 1 + if (range_string[ip] == EOS) + ; + else if (IS_DIGIT(range_string[ip])) { + if (ctoi (range_string, ip, step) == 0) + ; + if (step == 0) + return (ERR) + } else if (range_string[ip] == '-') + ; + else + return (ERR) + } + + # Output the range triple. + ranges[1, nrange] = first + ranges[2, nrange] = last + ranges[3, nrange] = step + nvalues = nvalues + abs (last-first) / step + 1 + } + + return (ERR) # ran out of space +end + + +# IMX_GET_NEXT_NUMBER -- Given a list of ranges and the current file number, +# find and return the next file number. Selection is done in such a way +# that list numbers are always returned in monotonically increasing order, +# regardless of the order in which the ranges are given. Duplicate entries +# are ignored. EOF is returned at the end of the list. + +int procedure imx_get_next_number (ranges, number) + +int ranges[ARB] # Range array +int number # Both input and output parameter + +int ip, first, last, step, next_number, remainder + +begin + # If number+1 is anywhere in the list, that is the next number, + # otherwise the next number is the smallest number in the list which + # is greater than number+1. + + number = number + 1 + next_number = MAX_INT + + for (ip=1; ranges[ip] != EOLIST; ip=ip+3) { + first = min (ranges[ip], ranges[ip+1]) + last = max (ranges[ip], ranges[ip+1]) + step = ranges[ip+2] + if (step == 0) + call error (1, "Step size of zero in range list") + if (number >= first && number <= last) { + remainder = mod (number - first, step) + if (remainder == 0) + return (number) + if (number - remainder + step <= last) + next_number = number - remainder + step + } else if (first > number) + next_number = min (next_number, first) + } + + if (next_number == MAX_INT) + return (EOF) + else { + number = next_number + return (number) + } +end + + +# IMX_EXTMATCH -- Match extname against a comma-delimited list of patterns. + +bool procedure imx_extmatch (extname, patterns) + +char extname[ARB] #I Extension name to match +char patterns[ARB] #I Comma-delimited list of patterns +bool stat #O Match? + +int i, j, k, sz_pat, strlen(), patmake(), patmatch(), nowhite() +pointer sp, patstr, patbuf + +begin + stat = false + + sz_pat = strlen (patterns) + if (sz_pat == 0) + return (stat) + sz_pat = sz_pat + SZ_LINE + + call smark (sp) + call salloc (patstr, sz_pat, TY_CHAR) + call salloc (patbuf, sz_pat, TY_CHAR) + + i = nowhite (patterns, Memc[patstr], sz_pat) + if (i == 0) + stat = true + else if (i == 1 && Memc[patstr] == '*') + stat = true + else { + i = 1 + for (j=i;; j=j+1) { + if (patterns[j] != ',' && patterns[j] != EOS) + next + if (j - i > 0) { + if (j-i == 1 && patterns[i] == '*') { + stat = true + break + } + call strcpy (patterns[i], Memc[patstr+1], j-i) + Memc[patstr] = '^' + Memc[patstr+j-i+1] = '$' + Memc[patstr+j-i+2] = EOS + k = patmake (Memc[patstr], Memc[patbuf], sz_pat) + if (patmatch (extname, Memc[patbuf]) > 0) { + stat = true + break + } + } + if (patterns[j] == EOS) + break + i = j + 1 + } + } + + call sfree (sp) + return (stat) +end + + +# IMX_IN_RANGE -- Test number to see if it is in range. +# If the number is INDEFI then it is mapped to the maximum integer. + +bool procedure imx_in_range (ranges, number) + +int ranges[ARB] # Range array +int number # Number to be tested against ranges + +int ip, first, last, step, num + +begin + if (IS_INDEFI (number)) + num = MAX_INT + else + num = number + + for (ip=1; ranges[ip] != NULL; ip=ip+3) { + first = min (ranges[ip], ranges[ip+1]) + last = max (ranges[ip], ranges[ip+1]) + step = ranges[ip+2] + if (num >= first && num <= last) + if (mod (num - first, step) == 0) + return (true) + } + + return (false) +end diff --git a/sys/imio/imt/imxexpr.x b/sys/imio/imt/imxexpr.x new file mode 100644 index 00000000..55c185ef --- /dev/null +++ b/sys/imio/imt/imxexpr.x @@ -0,0 +1,222 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include <evexpr.h> +include <imset.h> +include <imhdr.h> +include <ctype.h> +include <lexnum.h> + +define LEN_USERAREA 28800 # allow for the largest possible header +define SZ_IMAGENAME 63 # max size of an image name +define SZ_FIELDNAME 31 # max size of a field name + +define DEBUG FALSE + + + +# IMX_MATCHEXPR -- Match the open image descriptor against the expression. + +bool procedure imx_matchexpr (im, expr) + +pointer im #I image descriptor +char expr[ARB] #I expression string + +bool stat +char val[SZ_LINE] +pointer o + +pointer imt_im # getop common +char imt_image[SZ_IMAGENAME] +char imt_field[SZ_FIELDNAME] +common /imtgop/ imt_im, imt_image, imt_field + +pointer evexpr() +extern imx_getop() +int locpr() +errchk locpr, evexpr + +begin + call aclrc (val, SZ_LINE) + call aclrc (imt_image, SZ_IMAGENAME) + call aclrc (imt_field, SZ_FIELDNAME) + + imt_im = im + if (expr[1] != EOS) { + iferr { + o = evexpr (expr, locpr (imx_getop), 0) + call imx_encodeop (o, val, SZ_LINE) + stat = O_VALB(o) + call xev_freeop (o) + call mfree (o, TY_STRUCT) + } then + stat = FALSE + + if (DEBUG) { + call eprintf ("expr = '%s' %b\n") + call pargstr (expr) ; call pargb (stat) + } + + return (stat) + } + + return (FALSE) +end + + +# IMX_SIFMATCH -- Check whether the file is a simple image matching the +# expression. + +bool procedure imx_sifmatch (fname, expr) + +char fname[ARB] #I image name +char expr[ARB] #I expression string + +pointer im +bool stat + +pointer immap() +bool imx_matchexpr (), streq() +errchk immap + +begin + if (expr[1] == EOS) + return (TRUE) + + iferr (im = immap (fname, READ_ONLY, 0)) { + return (FALSE) + } + + if (streq (expr, "yes")) + stat = TRUE + else + stat = imx_matchexpr (im, expr) + call imunmap (im) + + return (stat) +end + + +# IMX_GETOP -- Satisfy an operand request from EVEXPR. In this context, +# operand names refer to the fields of the image header. The following +# special operand names are recognized: +# +# . a string literal, returned as the string "." +# $ the value of the current field +# $F the name of the current field +# $I the name of the current image +# $T the current time, expressed as an integer +# +# The companion procedure HE_GETOPSETIMAGE is used to pass the image pointer +# and image and field names. + +procedure imx_getop (operand, o) + +char operand[ARB] # operand name +pointer o # operand (output) + +pointer imt_im # getop common +char imt_image[SZ_IMAGENAME] +char imt_field[SZ_FIELDNAME] +common /imtgop/ imt_im, imt_image, imt_field +bool streq() +long clktime() +errchk imx_getfield + +begin + if (streq (operand, ".")) { + call xev_initop (o, 1, TY_CHAR) + call strcpy (".", O_VALC(o), 1) + + } else if (streq (operand, "$")) { + call imx_getfield (imt_im, imt_field, o) + + } else if (streq (operand, "$F")) { + call xev_initop (o, SZ_FIELDNAME, TY_CHAR) + call strcpy (imt_field, O_VALC(o), SZ_FIELDNAME) + + } else if (streq (operand, "$I")) { + call xev_initop (o, SZ_IMAGENAME, TY_CHAR) + call strcpy (imt_image, O_VALC(o), SZ_IMAGENAME) + + } else if (streq (operand, "$T")) { + # Assignment of long into int may fail on some systems. Maybe + # should use type string and let database convert to long... + + call xev_initop (o, 0, TY_INT) + O_VALI(o) = clktime (long(0)) + + } else + call imx_getfield (imt_im, operand, o) +end + + +# IMX_GETFIELD -- Return the value of the named field of the image header as +# an EVEXPR type operand structure. + +procedure imx_getfield (im, field, o) + +pointer im # image descriptor +char field[ARB] # name of field to be returned +pointer o # pointer to output operand + +bool imgetb() +int ftype, imgeti(), imgftype() +real imgetr() + +begin + iferr { + ftype = imgftype (im, field) + } then { + call xev_initop (o, SZ_LINE, TY_CHAR) # keyword not found + call aclrc (O_VALC(o), SZ_LINE) + return + } + + switch (ftype) { + case TY_BOOL: + call xev_initop (o, 0, TY_BOOL) + O_VALB(o) = imgetb (im, field) + + case TY_SHORT, TY_INT, TY_LONG: + call xev_initop (o, 0, TY_INT) + O_VALI(o) = imgeti (im, field) + + case TY_REAL, TY_DOUBLE, TY_COMPLEX: + call xev_initop (o, 0, TY_REAL) + O_VALR(o) = imgetr (im, field) + + default: + call xev_initop (o, SZ_LINE, TY_CHAR) + call imgstr (im, field, O_VALC(o), SZ_LINE) + } +end + + +# IMX_ENCODEOP -- Encode an operand as returned by EVEXPR as a string. EVEXPR +# operands are restricted to the datatypes bool, int, real, and string. + +procedure imx_encodeop (o, outstr, maxch) + +pointer o # operand to be encoded +char outstr[ARB] # output string +int maxch # max chars in outstr + +begin + switch (O_TYPE(o)) { + case TY_BOOL: + call sprintf (outstr, maxch, "%b") + call pargb (O_VALB(o)) + case TY_CHAR: + call sprintf (outstr, maxch, "%s") + call pargstr (O_VALC(o)) + case TY_INT: + call sprintf (outstr, maxch, "%d") + call pargi (O_VALI(o)) + case TY_REAL: + call sprintf (outstr, maxch, "%g") + call pargr (O_VALR(o)) + default: + call error (1, "unknown expression datatype") + } +end diff --git a/sys/imio/imt/imxftype.x b/sys/imio/imt/imxftype.x new file mode 100644 index 00000000..e083f032 --- /dev/null +++ b/sys/imio/imt/imxftype.x @@ -0,0 +1,119 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include <syserr.h> +include <imhdr.h> +include "imx.h" + + +# IMX_FILETYPE -- Determine the file type. + +int procedure imx_filetype (fname) + +char fname[ARB] #i file name + +char img[SZ_FNAME], name[SZ_FNAME], buf[SZ_LINE] + +int i, nchars, fd +bool is_http_list + +int errcode(), open(), read(), access(), imaccess() +int strncmp(), strsearch(), isdirectory() +pointer im, immap() + +begin + # Check for a URL. + if (strncmp ("http://", fname, 7) == 0) + return (IMT_URL) + + call aclrc (name, SZ_FNAME) + if (fname[1] == '@') + call strcpy (fname[2], name, SZ_FNAME) + else + call strcpy (fname, name, SZ_FNAME) + + # See if it is a directory. + if (isdirectory (name, buf, SZ_LINE) > 0) + return (IMT_DIR) + + # Check for concatenated strings. + if (strsearch (fname, "//") > 0) { + if (isdirectory (fname, buf, SZ_LINE) > 0) + return (IMT_DIR) + else + return (IMT_FILE) + } + + call aclrc (img, SZ_FNAME) # PHU + call sprintf (img, SZ_FNAME, "%s[0]") + call pargstr (name) + + # Get a peek at the file. + call aclrc (buf, SZ_LINE) + if (imaccess (name, READ_ONLY) == YES || + imaccess (img, READ_ONLY) == YES) { + return (IMT_IMAGE); + } else if (access (name, 0, 0) == YES) { + fd = open (name, READ_ONLY, TEXT_FILE) + nchars = read (fd, buf, SZ_LINE) + call strupr (buf) + call close (fd) + } + + # See if it might be an image of some kind. + if (strncmp (buf, "SIMPLE", 6) == 0) { + + ifnoerr (im = immap (name, READ_ONLY, 0)) { # SIF, OIF, etc + call imunmap (im) + return (IMT_IMAGE) + } + + do i = 0, 1 { # MEF + call aclrc (img, SZ_FNAME) + call sprintf (img, SZ_FNAME, "%s[%d]") + call pargstr (name) + call pargi (i) + + iferr (im = immap (img, READ_ONLY, 0)) { + switch (errcode()) { + case SYS_FXFRFEOF: + break + case SYS_IKIEXTN: + next + case SYS_IKIOPEN: + if (i == 0) + next + break + default: + call erract (EA_ERROR) + } + } else { + call imunmap (im) + return (IMT_IMAGE) + } + } + + } else { + + # If we get this far, we have a file of some kind. See if it is a + # list of URLs, a VOTable, or a plain file. + is_http_list = FALSE + fd = open (name, READ_ONLY, TEXT_FILE) + do i = 1, 10 { + call aclrc (buf, SZ_LINE) + nchars = read (fd, buf, SZ_LINE) + call strupr (buf) + if (strsearch (buf, "VOTABLE") > 0) { + call close (fd) + return (IMT_VOTABLE) + } else if (strncmp (buf, "http://", 7) == 0) + is_http_list = TRUE + } + call close (fd) + } + + if (is_http_list) + return (IMT_TABLE) + else + return (IMT_FILE) +end diff --git a/sys/imio/imt/imxparse.x b/sys/imio/imt/imxparse.x new file mode 100644 index 00000000..f26f0918 --- /dev/null +++ b/sys/imio/imt/imxparse.x @@ -0,0 +1,203 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <ctype.h> +include <imhdr.h> +include "imx.h" + + +define IMT_INDEX 1 +define IMT_NAME 2 +define IMT_VER 3 +define IMT_EXPR 4 + +define DEBUG FALSE + + + +# IMX_PARSE -- Parse a filename to extract index ranges, extension names, +# versions and filtering expressions. + +int procedure imx_parse (input, fname, index, extname, extver, + expr, sec, ikparams, maxch) + +char input[ARB] #i template string ptr +char fname[ARB] #o file name +char index[ARB] #o index range string +char extname[ARB] #o extension name +char extver[ARB] #o extension version +char expr[ARB] #o filtering expression string +char sec[ARB] #o image section string +char ikparams[ARB] #o image kernel section params +int maxch #i max chars in string params + +pointer im +int nchars, ip, idx +char comma, lexpr[SZ_LINE], subex[SZ_LINE], name[SZ_PATHNAME] + +int imx_breakout(), imx_next_expr(), imx_expr_type(), stridx() +pointer immap() + +begin + call aclrc (expr, maxch) # initialize + call aclrc (index, maxch) + call aclrc (fname, maxch) + call aclrc (extver, maxch) + call aclrc (extname, maxch) + call aclrc (ikparams, maxch) + call aclrc (lexpr, SZ_LINE) + + + # Separate the filename from the expression string. + nchars = imx_breakout (input, NO, fname, lexpr, sec, ikparams, maxch) + + # Parse into sub-expression strings, breaking it up into the + # appropriate form depending on the contents. + if (lexpr[1] != EOS) { + ip = 1 + while (imx_next_expr (lexpr, ip, subex, maxch) != EOS) { + + if (DEBUG) { + call eprintf ("parse subex = '%s'\t\t'%s'\n") + call pargstr (subex) ; call pargstr (lexpr) + } + + switch (imx_expr_type (subex)) { + case IMT_INDEX: + call strcpy (subex, index, maxch) + case IMT_NAME: + call strcpy (subex, extname, maxch) + case IMT_VER: + comma = ',' + idx = stridx (comma, subex) + call strcpy (subex[idx+1], extver, maxch) + subex[idx] = '\0' + call strcpy (subex, extname, maxch) + case IMT_EXPR: + if (expr[1] != EOS) { + call strcat ("||", expr, maxch) + call strcat (subex, expr, maxch) + } else + call strcpy (subex, expr, maxch) + default: + call error (1, "unknown expression type") + } + + ip = ip + 1 + } + } + + if (DEBUG) { + call eprintf ("final expr = '%s' index = '%s' sec = '%s'\n") + call pargstr (expr) + call pargstr (index) + call pargstr (sec) + } + + call aclrc (name, SZ_PATHNAME) + if (fname[1] == '@') + call strcpy (fname[2], name, SZ_PATHNAME) + else + call strcpy (fname, name, SZ_PATHNAME) + if (index[1] != EOS) { + call strcat ("[", name, SZ_PATHNAME) + call strcat (index, name, SZ_PATHNAME) + call strcat ("]", name, SZ_PATHNAME) + } + if (sec[1] != EOS) { + call strcat ("[", name, SZ_PATHNAME) + call strcat (sec, name, SZ_PATHNAME) + call strcat ("]", name, SZ_PATHNAME) + } + +# iferr { +# im = immap (name, READ_ONLY, 0) +# call imunmap (im) +# } then +# ; + + return (nchars) +end + + +# IMX_NEXT_EXPR -- Get the next sub expression from the string. Expressions +# are delimited by semicolons, the location in the expression string is +# updated. + +int procedure imx_next_expr (expr, ip, subex, maxch) + +char expr[ARB] #i input expression string +int ip #u location in expr +char subex[ARB] #o sub expression string +int maxch #i max size of subexpr string + +char op + +begin + if (expr[ip] == EOS) + return (EOS) + + # Skip leading whitespace/delimiters. + while (IS_WHITE(expr[ip]) || expr[ip] == ';') + ip = ip + 1 + + op = 1 # copy until EOS or next delimiter + while (expr[ip] != EOS && expr[ip] != ';' && expr[ip] != ']') { + subex[op] = expr[ip] + ip = ip + 1 + op = op + 1 + } + subex[op] = EOS + + if (expr[ip] == ']') + ip = ip + 1 + + return (ip) +end + + +# IMX_EXPR_TYPE -- Determine the type of expression we have. A range list +# is assumed to be an extension index list; a single alphabetic word is +# assumed to be an extension name, if followed by a numeric value it also +# contains an extension version; anything else is a selection expression. + +int procedure imx_expr_type (expr) + +char expr[ARB] #i expression + +int ip, len +char ch +int strlen (), stridxs(), stridx() + +begin + len = strlen (expr) + + # [<expr>] + ch = expr[1] + if ((IS_ALNUM(expr[1]) || stridx (ch, "('\"") > 0) && + stridxs ("?=:()<>&|@", expr) != 0) + return (IMT_EXPR) + + # [extname,extver] + ch = ',' + if (IS_ALPHA(expr[1]) && IS_DIGIT(expr[len]) && stridx (ch, expr) > 0) + return (IMT_VER) + + # [extname] + if (IS_ALPHA(expr[1]) && stridx (ch, expr) == 0) + return (IMT_NAME) + + # [index] or [index_range] + if ((IS_DIGIT(expr[1])) || + ((expr[1] == '+' || expr[1] == '-') && IS_DIGIT(expr[2]))) { + for (ip=1; expr[ip] != EOS; ip = ip + 1) { + ch = expr[ip] + if (! IS_DIGIT(ch)) { + if (stridx (ch, "-x,+") == 0) + return (IMT_EXPR) + } + } + return (IMT_INDEX) + } + + return (0) +end diff --git a/sys/imio/imt/imxpreproc.x b/sys/imio/imt/imxpreproc.x new file mode 100644 index 00000000..b0faccfc --- /dev/null +++ b/sys/imio/imt/imxpreproc.x @@ -0,0 +1,539 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "imx.h" + +define DEBUG FALSE +define SZ_PREFIX 2 + + +pointer procedure imx_preproc (template) + +char template[ARB] #i input template string + +pointer exp, pre, out, op, list +char file[SZ_PATHNAME] +char mods[SZ_LINE], fname[SZ_LINE] +int i, j, osize, len, llen, nmods + +define output {Memc[out+op]=$1;op=op+1} +define outstr {len=strlen($1);for(j=1;j<=len;j=j+1)output($1[j])} +define outcomma {if(($1))output(',')} + +pointer imx_fnexpand (), imx_preproc_list() +pointer fntopnb() +int fntlenb(), fntgfnb(), strlen(), strsearch(), strncmp(), imx_split() + +begin + # First Pass: Do any filename expansion in the template, maintaining + # the '@' prefix and any modifiers. The result is a comma-delimited + # list we process later to expand further. + + exp = imx_fnexpand (template) + + # Second Pass: Process the matched list to expand the '@' files and + # modifiers into a simple comma-delimited list the FNT interface + # will process. + + pre = imx_preproc_list (Memc[exp]) + + # Third Pass: Handle concatenation in the filenames. + if ((strncmp (Memc[pre],"http://",7) == 0) || + (strncmp (Memc[pre],"file://",7) == 0)) { + osize = strlen (Memc[pre]) + call calloc (out, osize, TY_CHAR) + call strcpy (Memc[pre], Memc[out], osize) + + } else if (strsearch(Memc[pre],"//") > 0 && + strsearch(Memc[pre],".fits") > 0) { + + # FIXME -- Need to handle the case of concatenation with + # a MEF file. Problem is, expanding the MEF requires we + # recursively call ourselves to expand the image so we + # need to do some restructuring. For example, + # + # foo // @mef.fits -> foomef.fits[1],foomef.fits[2], .... + # @mef.fits // foo -> meffoo.fits[1],meffoo.fits[2], .... + + call error (0, "Image expansion/concatenation not yet supported.") + + + } else if (strsearch (Memc[pre], "//") > 0) { + + nmods = imx_split (Memc[pre], fname, mods, SZ_LINE) + list = fntopnb (fname, YES) + llen = fntlenb (list) + + osize = strlen (Memc[pre]) + call calloc (out, osize * 2, TY_CHAR) + + op = 0 + for (i=0; i < llen; i=i+1) { + call aclrc (file, SZ_PATHNAME) + if (fntgfnb (list, file, SZ_PATHNAME) == EOF) + break + + if ((op + strlen (file) + strlen (mods) + 3) >= osize) { + osize = osize + SZ_LINE + call realloc (out, osize, TY_CHAR) + } + + # FIXME ??? + #outcomma (i > 0); output ('@'); outstr(file) ; outstr(mods) + outcomma (i > 0); outstr(file) ; outstr(mods) + } + output ('\0') + call fntclsb (list) + + } else { + osize = strlen (Memc[pre]) + call calloc (out, osize, TY_CHAR) + call strcpy (Memc[pre], Memc[out], osize) + } + + if (DEBUG) { + call eprintf ("pre exp = '%s'\n") ; call pargstr (Memc[exp]) + call eprintf ("pre pre = '%s'\n") ; call pargstr (Memc[pre]) + call eprintf ("pre out = '%s'\n") ; call pargstr (Memc[out]) + } + + call mfree (exp, TY_CHAR) # clean up + call mfree (pre, TY_CHAR) + + return (out) +end + + +# IMX_FNEXPAND -- Do any filename expansion in the template, maintaining the +# '@' prefix and any modifiers. The result is a comma-delimited list we +# process later to expand further. + +pointer procedure imx_fnexpand (template) + +char template[ARB] #i input template string + +pointer elem, ep, op, out, listp, sz_out, op_start, op_end +int i, j, ip, in, len, llen, nelem, fi, fo +char prefix[SZ_PREFIX], fname[SZ_PATHNAME], mods[SZ_LINE] +char left[SZ_PATHNAME], right[SZ_PATHNAME] +char file[SZ_PATHNAME], cfname[SZ_PATHNAME], osfn[SZ_PATHNAME] + +define output {Memc[op]=$1;op=op+1} +define outstr {len=strlen($1);for(j=1;j<=len;j=j+1)output($1[j])} + +int fntopnb(), fntgfnb(), fntlenb(), strlen(), stridxs(), strsearch() +int imx_get_element(), strncmp(), stridx() + +begin + # Allocate an intial string buffer. + call calloc (out, SZ_FNT, TY_CHAR) + call calloc (elem, SZ_FNT, TY_CHAR) + + in = 1 + nelem = 0 + op = out + op_start = out + op_end = out + SZ_FNT - 1 + sz_out = SZ_FNT + + while (imx_get_element (template, in, Memc[elem], SZ_FNT) != EOS) { + + ep = elem + nelem = nelem + 1 + outcomma(nelem > 1) + + call aclrc (prefix, SZ_PREFIX) + call aclrc (fname, SZ_PATHNAME) + call aclrc (mods, SZ_LINE) + + # Gather any prefix '@' symbols. + if (Memc[elem] == '@') { + for (i=1; Memc[ep] == '@'; i=i+1) { + prefix[i] = Memc[ep] + ep = ep + 1 + } + } else { + ip = stridx ('@', Memc[elem]) + if (ip > 1) { + call strcpy (Memc[elem], prefix, ip-1) + ep = elem + ip - 1 + prefix[ip] = EOS + call strcat ("//", prefix[ip], SZ_PREFIX) + } + } + + # Get the filename component up to the EOS or the modifiers. + for (i=1; Memc[ep] != '[' && Memc[ep] != EOS; i=i+1) { + fname[i] = Memc[ep] + ep = ep + 1 + } + + if (strncmp ("http://", fname, 7) == 0) { + call fmapfn ("cache$", osfn, SZ_PATHNAME) + call strupk (osfn, osfn, SZ_PATHNAME) + + #call fcadd (osfn, fname, "fits", cfname, SZ_PATHNAME) + call fcadd (osfn, fname, "", cfname, SZ_PATHNAME) + + call strcpy (cfname, fname, SZ_PATHNAME) + + } else if (strncmp ("file://", fname, 7) == 0) { + fi = 8 + if (strncmp ("file:///localhost", fname, 17) == 0) + fi = 18 + else if (strncmp ("file://localhost", fname, 16) == 0) + fi = 17 + + for (fo=1; fname[fi] != EOS; fi=fi+1) { + if (fname[fi] == '/' && fname[fi+1] == '/') + fi = fi + 1 + cfname[fo] = fname[fi] + fo = fo + 1 + } + call strcpy (cfname, fname, SZ_PATHNAME) + } + + # Get the modifier strings. + for (i=1; Memc[ep] != EOS ; i=i+1) { + mods[i] = Memc[ep] + ep = ep + 1 + } + + + if (DEBUG) { + call eprintf ("fnexp: '%s' --> '%s' '%s' '%s'\n") + call pargstr (Memc[elem]); call pargstr (prefix); + call pargstr (fname); call pargstr (mods) + } + + # Expand wildcards if needed. + if (stridxs("*?", fname) > 0) { + + # FIXME - Need to do concatenation here ...?? + if (strsearch (fname, "//") > 0) { + call aclrc (left, SZ_PATHNAME) + call aclrc (right, SZ_PATHNAME) + + # Gather the left and right side of a concatenation with + # wildcards. Expand the side with the wildcard but + # maintain the concatenation so we keep the previous + # behavior in how these processed. + for (ip=1; fname[ip] != '/'; ip=ip+1) + left[ip] = fname[ip] + ip = ip + 2 + for (i=1; fname[ip] != EOS; ip=ip+1) { + right[i] = fname[ip] + i = i + 1 + } + + if (stridxs("*?", left) > 0) { + listp = fntopnb (left, YES) + llen = fntlenb (listp) + for (i=0; i < llen; i=i+1) { + call aclrc (file, SZ_PATHNAME) + if (fntgfnb (listp, file, SZ_PATHNAME) == EOF) + break + outcomma (i > 0) + outstr(prefix) + outstr(file) ; outstr("//") ; outstr(right) + } + call fntclsb (listp) + } else { + listp = fntopnb (right, YES) + llen = fntlenb (listp) + for (i=0; i < llen; i=i+1) { + call aclrc (file, SZ_PATHNAME) + if (fntgfnb (listp, file, SZ_PATHNAME) == EOF) + break + outcomma (i > 0) + outstr(prefix) + outstr(left) ; outstr("//") ; outstr(file) + } + call fntclsb (listp) + } + next + + } else { + listp = fntopnb (fname, YES) + llen = fntlenb (listp) + for (i=0; i < llen; i=i+1) { + call aclrc (file, SZ_PATHNAME) + if (fntgfnb (listp, file, SZ_PATHNAME) == EOF) + break + outcomma ( i > 0) + outstr(prefix) ; outstr(file) ; outstr(mods) + + + # Reallocate the output string if needed. + if ((op_end - op) < SZ_FNAME || op >= op_end) { + sz_out = sz_out + SZ_FNT + len = (op - out - 1) + + call calloc (op_start, sz_out, TY_CHAR) + call amovc (Memc[out], Memc[op_start], len) + for (op=op_start; Memc[op] != EOS; ) + op = op + 1 + + op_end = op_start + sz_out + call mfree (out, TY_CHAR) + out = op_start + } + } + call fntclsb (listp) + } + + + } else { + outstr(prefix) ; outstr(fname) ; outstr(mods) + } + + call aclrc (Memc[elem], SZ_FNT) + } + output ('\0') + + call mfree (elem, TY_CHAR) + return (out) +end + + +# IMX_PREPROC_LIST -- Process the expanded filename string to open any +# @files and produce final expression strings. + +pointer procedure imx_preproc_list (template) + +char template[ARB] #i template string + +pointer tp, ip, op, itp, listp, elem +int i, lp, in, len, tend, tlen, plen, llen +int nchars, atat, nelem, in_filter +char ch, file[SZ_LINE], expr[SZ_LINE], fname[SZ_PATHNAME] +char ikparams[SZ_LINE], sec[SZ_LINE], dirname[SZ_PATHNAME] + +define output {Memc[op]=$1;op=op+1} + +int fntopnb(), fntgfnb(), fntlenb(), strlen(), stridxs(), strsearch() +int access(), imx_get_element(), imx_breakout(), isdirectory() + +begin + # Allocate an intial string buffer. + tlen = strlen (template) + plen = max(strlen(template)*2, SZ_FNT) + call calloc (tp, plen, TY_CHAR) + call calloc (itp, tlen + 1, TY_CHAR) + call calloc (elem, SZ_FNT, TY_CHAR) + + in = 1 + op = tp + nelem = 0 + while (imx_get_element (template, in, Memc[elem], SZ_FNT) != EOS) { + + # Break out the filename and expression. + nchars = imx_breakout (Memc[elem], NO, file, expr, + sec, ikparams, SZ_LINE) + + nelem = nelem + 1 + outcomma (nelem > 1) + + atat = NO + call aclrc (Memc[itp], tlen+1) + + if (stridxs("[]", Memc[elem]) > 0 && expr[1] != EOS) { + if (Memc[elem] == '@' || strsearch (Memc[elem], "//") > 0) + call sprintf (Memc[itp], tlen+1, "%s") + else + call sprintf (Memc[itp], tlen+1, "@%s") + call pargstr (Memc[elem]) + + } else if (strsearch (Memc[elem], "][") > 0) { + call sprintf (Memc[itp], tlen+1, "@%s") + call pargstr (Memc[elem]) + + } else { + # Simple filename or @file, just copy it out if it exists. + if (Memc[elem] == '@') { + if (Memc[elem+1] != '@' && access (Memc[elem+1],0,0) == NO) + if (strsearch (Memc[elem], "//") == 0) + next + if (Memc[elem+1] == '@') { + lp = 1 + atat = YES + call sprintf (Memc[itp], tlen+1, "%s") + call pargstr (Memc[elem]) + } else { + lp = 0 + for (; Memc[elem+lp] != EOS; lp=lp+1) + output (Memc[elem+lp]) + next + } + } else { + lp = 0 + for (; Memc[elem+lp] != EOS; lp=lp+1) + output (Memc[elem+lp]) + } + } + + ip = itp + tend = itp + strlen (Memc[itp]) - 1 + ch = Memc[ip] + + if (ch == '@') { # @file + + if (Memc[ip+1] == '@') { # @@file + atat = YES + ip = ip + 1 + } + + if (atat == NO) { + # No metachars, copy item entirely to output string. + in_filter = NO + while (Memc[ip] != EOS && ip <= tend) { + if (Memc[ip] == '[') in_filter = YES + if (Memc[ip] == ']') in_filter = NO + if (Memc[ip] == ',' && in_filter == NO) { + output (Memc[ip]) + ip = ip + 1 + break + } + output (Memc[ip]) + ip = ip + 1 + } + next + } + + if (atat == YES) { + if (isdirectory (file[3], dirname, SZ_PATHNAME) > 0) { + len = strlen (file) + if (file[len] != '$') + call strcat ("/", file, SZ_FNAME) + call strcat ("*.fits", file, SZ_FNAME) + listp = fntopnb (file[3], YES) + } else + listp = fntopnb (file[2], YES) + } else + listp = fntopnb (file, YES) + + llen = fntlenb (listp) + for (i=0; i < llen; i=i+1) { + call aclrc (fname, SZ_PATHNAME) + if (fntgfnb (listp, fname, SZ_PATHNAME) == EOF) + break + + if (atat == YES) + output ('@') + for (lp=1; fname[lp] != EOS; lp=lp+1) + output (fname[lp]) + if (expr[1] != EOS) { # append extension info + output ('[') + for (lp=1; expr[lp] != EOS; lp=lp+1) + output (expr[lp]) + if (ikparams[1] != EOS) { + output (',') + for (lp=1; ikparams[lp] != EOS; lp=lp+1) + output (ikparams[lp]) + } + output (']') + } + if (sec[1] != EOS) { # append any section notation + output ('[') + for (lp=1; sec[lp] != EOS; lp=lp+1) + output (sec[lp]) + output (']') + } + + outcomma (i < (llen-1)) + } + call fntclsb (listp) + ip = ip + nchars + 1 + + if (Memc[ip+1] == ',') + break + } # else + # call strcpy (Memc[elem], Memc[op], SZ_FNT) + } + + call mfree (itp, TY_CHAR) + call mfree (elem, TY_CHAR) + + return (tp) +end + + +# IMX_GET_ELEMENT -- Get the next element of a list template. + +int procedure imx_get_element (template, ip, elem, maxch) + +char template[ARB] #i input template string +int ip #u template index +char elem[ARB] #o output string buffer +int maxch #i max size of output element + +int op, level, done +char ch + +begin + op = 1 + done = 0 + level = 0 + + if (template[ip] == EOS) + return (EOS) + if (template[ip] == ',') + ip = ip + 1 + + call aclrc (elem, maxch) + while (template[ip] != EOS) { + ch = template[ip] + + if (ch == EOS || (ch == ',' && level == 0)) { + done = 1 + } else if (ch == '[') + level = level + 1 + else if (ch == ']') + level = level - 1 + + if (done == 1) { + return (ip + 1) + } else + elem[op] = ch + + ip = ip + 1 + op = op + 1 + } + + return (ip) +end + + +# IMX_SPLIT -- Split a list element into the coarse filename and modifiers + +int procedure imx_split (in, fname, mods, maxch) + +char in[ARB] #i input template string +char fname[ARB] #o filename +char mods[ARB] #o modifier strings +int maxch #i max size of output string + +int i, j, nmods + +begin + # Allocate an intial string buffer. + nmods = 0 + call aclrc (mods, maxch) + call aclrc (fname, maxch) + + + # Gather any prefix '@' symbols. + for (i=1; in[i] != '[' && in[i] != EOS && i < maxch; i=i+1) + fname[i] = in[i] + + # Get the filename component up to the EOS or the modifiers. + if (in[i] == '[') { + for (j=1; in[i] != EOS && i < maxch && j < maxch; i=i+1) { + mods[j] = in[i] + j = j + 1 + if (in[i] == '[') + nmods = nmods + 1 + } + } + + return (nmods) +end diff --git a/sys/imio/imt/mkpkg b/sys/imio/imt/mkpkg new file mode 100644 index 00000000..eca1a520 --- /dev/null +++ b/sys/imio/imt/mkpkg @@ -0,0 +1,24 @@ +# Update the IMIO portion of the LIBEX library. + +$checkout libex.a ../ +$update libex.a +$checkin libex.a ../ +$exit + +libex.a: + imt.x + imx.x imx.h <error.h> + imxbreakout.x + imxparse.x imx.h <ctype.h> + imxescape.x imx.h + imxexpand.x imx.h <ctype.h> <error.h> <imhdr.h> <imset.h> <mach.h> + imxexpr.x imx.h <ctype.h> <error.h> <evexpr.h> <lexnum.h> + imxftype.x imx.h <error.h> + imxpreproc.x imx.h + ; + +test: + $call libpkg.a + $omake zzdebug.x + $link zzdebug.o libpkg.a + ; diff --git a/sys/imio/imt/t_urlget.x b/sys/imio/imt/t_urlget.x new file mode 100644 index 00000000..e0e7bf26 --- /dev/null +++ b/sys/imio/imt/t_urlget.x @@ -0,0 +1,94 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include <syserr.h> +include <imhdr.h> +include <imset.h> +include <mach.h> + +task urlget = t_urlget + + + +# URLGET -- Do an HTTP GET of a URL to the named file. + +procedure t_urlget () + +pointer reply +char url[SZ_PATHNAME], fname[SZ_PATHNAME], extn[SZ_PATHNAME] +char cache[SZ_PATHNAME], lfname[SZ_PATHNAME] +int nread +bool use_cache, verbose + +int url_get() +bool fcaccess() + +begin + # Get the parameters + call clgstr ("url", url, SZ_PATHNAME) + + call url_to_name (url, fname, SZ_PATHNAME) + call strcpy ("", extn, SZ_PATHNAME) + call strcpy ("/tmp/cache/", cache, SZ_PATHNAME) + verbose = true + use_cache = false + + + # Tell them what we're doing. + if (verbose) { + call printf ("%s -> %s\n") + call pargstr (url) + call pargstr (fname) + call flush (STDOUT) + } + + # Retrieve the URL. + if (use_cache) { + call aclrc (lfname, SZ_FNAME); + + if (fcaccess (cache, url, "fits")) { + call fcname (cache, url, "f", lfname, SZ_PATHNAME) + if (extn[1] != EOS) { + # Add an extension to the cached file. + call strcat (".", lfname, SZ_PATHNAME) + call strcat (extn, lfname, SZ_PATHNAME) + } + } else { + # Add it to the cache, also handles the download. + call fcadd (cache, url, extn, lfname, SZ_PATHNAME) + } + call fcopy (lfname, fname) + + } else { + # Not in cache, or not using the cache, so force the download. + call calloc (reply, SZ_LINE, TY_CHAR) + nread = url_get (url, fname, reply) + call mfree (reply, TY_CHAR) + } +end + + +# URL_TO_NAME -- Generate a filename from a URL. + +procedure url_to_name (url, name, maxch) + +char url[ARB] #i URL being accessed +char name[ARB] #o output name +int maxch #i max size of output name + +int ip, strlen() +char ch + +begin + ip = strlen (url) + while (ip > 1) { + ch = url[ip] + if (ch == '/' || ch == '?' || ch == '&' || ch == ';' || ch == '=') { + call strcpy (url[ip+1], name, maxch) + return + } + ip = ip - 1 + } + + call strcpy (url[ip], name, maxch) +end diff --git a/sys/imio/imt/zzdebug.x b/sys/imio/imt/zzdebug.x new file mode 100644 index 00000000..746fc6f1 --- /dev/null +++ b/sys/imio/imt/zzdebug.x @@ -0,0 +1,227 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include <syserr.h> +include <imhdr.h> +include <imset.h> +include <mach.h> +include "imx.h" + + +task imt = t_imt, + parse = t_parse, + fnexpand = t_fnexpand, + prelist = t_prelist, + preproc = t_preproc, + breakout = t_breakout, + imexpand = t_imexpand, + fexpand = t_fexpand + + + +# IMT -- Test the image template package. + +procedure t_imt () + +char template[SZ_LINE] +char image[SZ_FNAME] + +pointer imt, im, imtopen(), immap() +int i, imtgetim() +bool num, clgetb() + +begin + call clgstr ("in", template, SZ_LINE) + num = clgetb ("number") + + imt = imtopen (template) + + for (i=0; imtgetim (imt, image, SZ_FNAME) != EOF; i=i+1) { + + if (num) { + im = immap (image, READ_ONLY, 0) + call printf ("%3d %s %d x %d\n") + call pargi (i+1) + call pargstr (image) + call pargi (IM_LEN(im,1)) + call pargi (IM_LEN(im,2)) + call imunmap (im) + } else { + if (i > 0) + call printf (",") + call printf ("%s") + call pargstr (image) + } + } + call printf ("\n") + call printf ("Nimages = %d\n") + call pargi (i) + + call imtclose (imt) +end + + +# PARSE -- Test the image template package expression parse. + +procedure t_parse () + +char template[SZ_LINE], name[SZ_LINE], index[SZ_LINE], ikparams[SZ_LINE] +char extname[SZ_LINE], extver[SZ_LINE], expr[SZ_LINE], sec[SZ_LINE] + +int nch, imx_parse() + +begin + call clgstr ("in", template, SZ_LINE) + + nch = imx_parse (template, name, index, extname, extver, + expr, sec, ikparams, SZ_LINE) + + call eprintf ("%s\n") ; call pargstr (template) + call eprintf ("\tname\t= %s\n") ; call pargstr (name) + call eprintf ("\tindex\t= %s\n") ; call pargstr (index) + call eprintf ("\textname\t= %s\n") ; call pargstr (extname) + call eprintf ("\textver\t= %s\n") ; call pargstr (extver) + call eprintf ("\texpr\t= %s\n") ; call pargstr (expr) + call eprintf ("\tikparams\t= %s\n") ; call pargstr (ikparams) + call eprintf ("\tsec\t= %s\n") ; call pargstr (sec) +end + + +# FNEXPAND -- Test the image template package pre-processor. + +procedure t_fnexpand () + +char template[SZ_LINE] + +pointer pp, imx_fnexpand() + +begin + call clgstr ("in", template, SZ_LINE) + + pp = imx_fnexpand (template) + + call eprintf ("%s\n") + call pargstr (Memc[pp]) + call mfree (pp, TY_CHAR) +end + + +# PRELIST -- Test the image template package pre-processor. + +procedure t_prelist () + +char template[SZ_LINE] + +pointer pp, imx_preproc_list() + +begin + call clgstr ("in", template, SZ_LINE) + + pp = imx_preproc_list (template) + + call eprintf ("%s\n") + call pargstr (Memc[pp]) + call mfree (pp, TY_CHAR) +end + + +# PREPROC -- Test the image template package pre-processor. + +procedure t_preproc () + +char template[SZ_LINE] + +pointer pp, imx_preproc() + +begin + call clgstr ("in", template, SZ_LINE) + + pp = imx_preproc (template) + + call eprintf ("%s\n") + call pargstr (Memc[pp]) + call mfree (pp, TY_CHAR) +end + + +# BREAKOUT -- Test the image template package expression breakout code. + +procedure t_breakout () + +char template[SZ_LINE] + +int nchars +char image[SZ_LINE], expr[SZ_LINE], sec[SZ_LINE], ikparams[SZ_LINE] + +int imx_breakout() + +begin + call clgstr ("in", template, SZ_LINE) + + nchars = imx_breakout(template, NO, image, expr, sec, ikparams, SZ_LINE) + + call eprintf ("nchars=%d image='%s' expr='%s' sec='%s' ik='%s'\n") + call pargi (nchars) + call pargstr (image) + call pargstr (expr) + call pargstr (sec) + call pargstr (ikparams) +end + + +# IMEXPAND -- Test the MEF image expansion. + +procedure t_imexpand () + +char template[SZ_LINE] +int nimages + +pointer imt, imx_imexpand() + +begin + call clgstr ("in", template, SZ_LINE) + + imt = imx_imexpand (template, + "", # expr + "", # index + "", # extname + "", # extver + "", # ikparams + "", # sections + nimages) + + call printf ("nimages = %d\n%s\n"); + call pargi (nimages) + call pargstr (Memc[imt]) + + call mfree (imt, TY_CHAR) +end + + +# FEXPAND -- Test the filename expansion. + +procedure t_fexpand () + +char template[SZ_LINE] +int nimages + +pointer imt, imx_fexpand() + +begin + call clgstr ("in", template, SZ_LINE) + + imt = imx_fexpand (template, + "", # expr + "", # index + "", # extname + "", # extver + "", # ikparams + "", # sections + nimages) + + call printf ("nimages = %d\n%s\n"); + call pargi (nimages) + call pargstr (Memc[imt]) + + call mfree (imt, TY_CHAR) +end diff --git a/sys/imio/imunmap.x b/sys/imio/imunmap.x new file mode 100644 index 00000000..dd2290b1 --- /dev/null +++ b/sys/imio/imunmap.x @@ -0,0 +1,61 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include <imio.h> + +# IMUNMAP -- Unmap a image. Flush the output buffer, append the bad pixel +# list, update the image header. Close all files and return buffer space. + +procedure imunmap (im) + +pointer im + +int acmode +errchk imflush, close, imerr, iki_updhdr + +begin + acmode = IM_ACMODE(im) + + # Note that if no pixel i/o occurred, the pixel storage file will + # never have been opened or created. + + if (IM_PFD(im) != NULL) + call imflush (im) + + # Update the image header, if necessary (count of bad pixels, + # minimum and maximum pixel values, etc.). + + if (IM_UPDATE(im) == YES) { + if (acmode == READ_ONLY) + call imerr (IM_NAME(im), SYS_IMUPIMHDR) + + # Restore those fields of the image header that may have been + # modified to map a section (if accessing an existing image). + + switch (acmode) { + case NEW_COPY, NEW_IMAGE: + ; # Cannot access section of new image + default: + IM_NDIM(im) = IM_NPHYSDIM(im) + IM_MTIME(im) = IM_SVMTIME(im) + call amovl (IM_SVLEN(im,1), IM_LEN(im,1), IM_NDIM(im)) + } + + # Update the image header or mask storage file. + call iki_updhdr (im) + } + + # Physically close the image. + call iki_close (im) + + # If the image is a mask image and the PL_CLOSEPL flag is set, close + # the associated mask. + + if (IM_PL(im) != NULL && and(IM_PLFLAGS(im),PL_CLOSEPL) != 0) + call pl_close (IM_PL(im)) + + # Free all buffer space allocated by IMIO. + call imrmbufs (im) + call mfree (im, TY_STRUCT) +end diff --git a/sys/imio/imupk.gx b/sys/imio/imupk.gx new file mode 100644 index 00000000..a637e39d --- /dev/null +++ b/sys/imio/imupk.gx @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMUPK? -- Convert an array of pixels of datatype DTYPE into the datatype +# specified by the IMUPK? suffix character. + +procedure imupk$t (a, b, npix, dtype) + +PIXEL b[npix] +int a[npix], npix, dtype + +pointer bp + +begin + switch (dtype) { + case TY_USHORT: + call achtu$t (a, b, npix) + case TY_SHORT: + call achts$t (a, b, npix) + case TY_INT: + call achti$t (a, b, npix) + case TY_LONG: + call achtl$t (a, b, npix) + case TY_REAL: + call achtr$t (a, b, npix) + case TY_DOUBLE: + call achtd$t (a, b, npix) + case TY_COMPLEX: + call achtx$t (a, b, npix) + default: + call error (1, "Unknown datatype in imagefile") + } +end + + diff --git a/sys/imio/imwbpx.x b/sys/imio/imwbpx.x new file mode 100644 index 00000000..23794c89 --- /dev/null +++ b/sys/imio/imwbpx.x @@ -0,0 +1,97 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imset.h> +include <imio.h> + +# IMWBPX -- Write a line segment from an image with boundary extension. The +# line segment is broken up into three parts, i.e., left, center, and right. +# The left and right (out of bounds) regions are discarded, and the center +# region, if any, is written to the image. Inbounds data is conserved if a +# subraster which extends out of bounds is read and then rewritten, i.e., +# a read followed immediately by a rewrite of the same data does not modify +# the image. + +procedure imwbpx (im, ibuf, totpix, v, vinc) + +pointer im # image descriptor +char ibuf[ARB] # typeless buffer containing the data +int totpix # total number of pixels to write +long v[ARB] # vector pointer to start of line segment +long vinc[ARB] # step on each axis + +bool oob +int npix, ndim, sz_pixel, btype, ip, xstep, step, i +long xs[3], xe[3], x1, x2, p, v1[IM_MAXDIM], v2[IM_MAXDIM], linelen +errchk imwrpx +include <szpixtype.inc> + +begin + sz_pixel = pix_size[IM_PIXTYPE(im)] + ndim = IM_NPHYSDIM(im) + + # Flip the input array if the step size in X is negative. + if (vinc[1] < 0) + call imaflp (ibuf, totpix, sz_pixel) + + # Cache the left and right endpoints of the line segment and the + # image line length. + + xstep = abs (IM_VSTEP(im,1)) + linelen = IM_SVLEN(im,1) + x1 = v[1] + x2 = x1 + (totpix * xstep) - 1 + + # Compute the endpoints of the line segment in the three x-regions of + # the image. + + xs[1] = x1 # left oob region + xe[1] = min (0, x2) + xs[2] = max (x1, 1) # central inbounds region + xe[2] = min (x2, linelen) + xs[3] = max (x1, linelen + 1) # right oob region + xe[3] = x2 + + # Perform bounds mapping on the entire vector. The mapping for all + # dimensions higher than the first is invariant in what follows. + + call imbtran (im, v, v1, ndim) + + # Copy V1 to V2 and determine if the whole thing is out of bounds. + oob = false + do i = 2, ndim { + p = v1[i] + v2[i] = p + if (p < 1 || p > IM_SVLEN(im,i)) + oob = true + } + + btype = IM_VTYBNDRY(im) + ip = 1 + + do i = 1, 3 { + # Skip to next region if there are no pixels in this region. + npix = (xe[i] - xs[i]) / xstep + 1 + if (npix <= 0) + next + + # Map the endpoints of the segment. + call imbtran (im, xs[i], v1[1], 1) + call imbtran (im, xe[i], v2[1], 1) + + # Compute the starting vector V1, step in X, and the number of + # pixels in the region allowing for subsampling. + + if (v1[1] > v2[1]) { + step = -xstep + v1[1] = v2[1] + } else + step = xstep + + # Write the pixels if inbounds. + if (i == 2 && !oob) + call imwrpx (im, ibuf[ip], npix, v1, step) + + ip = ip + (npix * sz_pixel) + } +end diff --git a/sys/imio/imwrite.x b/sys/imio/imwrite.x new file mode 100644 index 00000000..724de8d7 --- /dev/null +++ b/sys/imio/imwrite.x @@ -0,0 +1,57 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <fset.h> +include <imio.h> + +define SZ_ZBUF 50 + +# IMWRITE -- Write data to the pixel storage file. Bounds checking has +# already been performed by the time IMWRITE is called. If writing beyond +# EOF (new image), write zeros until the indicated offset is reached. + +procedure imwrite (imdes, buf, nchars, offset) + +pointer imdes +char buf[ARB] +int nchars +long offset + +int fd +char zbuf[SZ_ZBUF] +long start, i +long fstatl() +errchk write, seek, fstatl +data zbuf /SZ_ZBUF*0,0/ + +begin + fd = IM_PFD(imdes) + + # Get file size. If writing beyond end of file (file_size+1), + # write out blocks of zeros until the desired offset is reached. + # The IM_FILESIZE parameter in the image descriptor is not always + # up to date, but does provide a lower bound on the size of the pixel + # storage file. + + if (offset >= IM_FILESIZE(imdes)) + IM_FILESIZE(imdes) = fstatl (fd, F_FILESIZE) + + if (offset-1 <= IM_FILESIZE(imdes)) { + # Write within bounds of file, or at EOF. + + call seek (fd, offset) + call write (fd, buf, nchars) + + } else { + # Write beyond EOF. + + IM_FILESIZE(imdes) = fstatl (fd, F_FILESIZE) + start = IM_FILESIZE(imdes) + 1 + + call seek (fd, start) + do i = start, offset, SZ_ZBUF + call write (fd, zbuf, min (SZ_ZBUF, offset-i)) + + call write (fd, buf, nchars) + IM_FILESIZE(imdes) = fstatl (fd, F_FILESIZE) + } +end diff --git a/sys/imio/imwrpx.x b/sys/imio/imwrpx.x new file mode 100644 index 00000000..3cdd2971 --- /dev/null +++ b/sys/imio/imwrpx.x @@ -0,0 +1,139 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> +include <syserr.h> +include <plset.h> +include <imhdr.h> +include <imio.h> + +# IMWRPX -- Write NPIX pixels, starting with the pixel at the coordinates +# specified by the vector V, from the buffer BUF to the pixel storage file. + +procedure imwrpx (im, buf, npix, v, xstep) + +pointer im # image descriptor +char buf[ARB] # generic buffer containing data to be written +int npix # number of pixels to be written +long v[ARB] # physical coords of first pixel to be written +int xstep # step size between output pixels + +bool rlio +long offset +pointer pl, sp, ibuf +long o_v[IM_MAXDIM] +int sz_pixel, sz_dtype, nbytes, nchars, ip, step + +int sizeof() +long imnote() +errchk imerr, imwrite +include <szpixtype.inc> + +begin + pl = IM_PL(im) + sz_dtype = sizeof (IM_PIXTYPE(im)) + sz_pixel = pix_size[IM_PIXTYPE(im)] + step = abs (xstep) + if (v[1] < 1 || ((npix-1) * step) + v[1] > IM_SVLEN(im,1)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + # Flip the pixel array end for end. + if (xstep < 0) + #call imaflp (buf, npix, sz_dtype) + call imaflp (buf, npix, sz_pixel) + + # Byte swap if necessary. + if (IM_SWAP(im) == YES) { + nbytes = npix * sz_dtype * SZB_CHAR + switch (sz_dtype * SZB_CHAR) { + case 2: + call bswap2 (buf, 1, buf, 1, nbytes) + case 4: + call bswap4 (buf, 1, buf, 1, nbytes) + case 8: + call bswap8 (buf, 1, buf, 1, nbytes) + } + } + + + if (pl != NULL) { + + # Need to unpack again on 64-bit systems. + if ((IM_PIXTYPE(im) == TY_INT || IM_PIXTYPE(im) == TY_LONG) && + SZ_INT != SZ_INT32) { + call iupk32 (buf, buf, npix) + } + + # Write to a pixel list. + rlio = (and (IM_PLFLAGS(im), PL_FAST+PL_RLIO) == PL_FAST+PL_RLIO) + call amovl (v, o_v, IM_MAXDIM) + nchars = npix * sz_pixel + + switch (IM_PIXTYPE(im)) { + case TY_SHORT: + if (rlio) + call pl_plrs (pl, v, buf, 0, npix, PIX_SRC) + else if (step == 1) + call pl_plps (pl, v, buf, 0, npix, PIX_SRC) + else { + do ip = 1, nchars, sz_pixel { + call pl_plpi (pl, o_v, buf[ip], 0, 1, PIX_SRC) + o_v[1] = o_v[1] + step + } + } + case TY_INT, TY_LONG: + if (rlio) + call pl_plri (pl, v, buf, 0, npix, PIX_SRC) + else if (step == 1) + call pl_plpi (pl, v, buf, 0, npix, PIX_SRC) + else { + do ip = 1, nchars, sz_pixel { + call pl_plpi (pl, o_v, buf[ip], 0, 1, PIX_SRC) + o_v[1] = o_v[1] + step + } + } + default: + call smark (sp) + call salloc (ibuf, npix, TY_INT) + + call acht (buf, Memi[ibuf], npix, IM_PIXTYPE(im), TY_INT) + if (rlio) + call pl_plri (pl, v, Memi[ibuf], 0, npix, PIX_SRC) + else if (step == 1) + call pl_plpi (pl, v, Memi[ibuf], 0, npix, PIX_SRC) + else { + do ip = 1, npix { + call pl_plpi (pl, o_v, Memi[ibuf+ip-1], 0, 1, PIX_SRC) + o_v[1] = o_v[1] + step + } + } + call sfree (sp) + } + + } else { + # Write to a file. Compute size of transfer. If transferring + # an entire line, increase size of transfer to the physical line + # length, to avoid having to enblock the data. NOTE: buffer must + # be large enough to guarantee no memory violation. + + offset = imnote (im, v) + + # If not subsampling (stepsize 1), write buffer to file in a + # single transfer. Otherwise, the pixels are not contiguous, + # and must be written individually. + + if (step == 1) { + if (v[1] == 1 && npix == IM_SVLEN(im,1)) + nchars = IM_PHYSLEN(im,1) * sz_pixel + else + nchars = npix * sz_pixel + call imwrite (im, buf, nchars, offset) + + } else { + nchars = npix * sz_pixel + for (ip=1; ip <= nchars; ip=ip+sz_pixel) { + call imwrite (im, buf[ip], sz_pixel, offset) + offset = offset + (sz_pixel * step) + } + } + } +end diff --git a/sys/imio/mkpkg b/sys/imio/mkpkg new file mode 100644 index 00000000..9daec830 --- /dev/null +++ b/sys/imio/mkpkg @@ -0,0 +1,106 @@ +# Update the IMIO portion of the LIBEX library. + +$checkout libex.a lib$ +$update libex.a +$checkin libex.a lib$ +$exit + +tfiles: + $set GFLAGS = "-k -t silrdx -p tf/" + $ifolder (tf/imupkr.x, imupk.gx) $generic $(GFLAGS) imupk.gx $endif + $ifolder (tf/imps3r.x, imps3.gx) $generic $(GFLAGS) imps3.gx $endif + $ifolder (tf/imps2r.x, imps2.gx) $generic $(GFLAGS) imps2.gx $endif + $ifolder (tf/imps1r.x, imps1.gx) $generic $(GFLAGS) imps1.gx $endif + $ifolder (tf/impnlr.x, impnl.gx) $generic $(GFLAGS) impnl.gx $endif + $ifolder (tf/impl3r.x, impl3.gx) $generic $(GFLAGS) impl3.gx $endif + $ifolder (tf/impl2r.x, impl2.gx) $generic $(GFLAGS) impl2.gx $endif + $ifolder (tf/impl1r.x, impl1.gx) $generic $(GFLAGS) impl1.gx $endif + $ifolder (tf/impgsr.x, impgs.gx) $generic $(GFLAGS) impgs.gx $endif + $ifolder (tf/impakr.x, impak.gx) $generic $(GFLAGS) impak.gx $endif + $ifolder (tf/imgs3r.x, imgs3.gx) $generic $(GFLAGS) imgs3.gx $endif + $ifolder (tf/imgs2r.x, imgs2.gx) $generic $(GFLAGS) imgs2.gx $endif + $ifolder (tf/imgs1r.x, imgs1.gx) $generic $(GFLAGS) imgs1.gx $endif + $ifolder (tf/imgnlr.x, imgnl.gx) $generic $(GFLAGS) imgnl.gx $endif + $ifolder (tf/imgl3r.x, imgl3.gx) $generic $(GFLAGS) imgl3.gx $endif + $ifolder (tf/imgl2r.x, imgl2.gx) $generic $(GFLAGS) imgl2.gx $endif + $ifolder (tf/imgl1r.x, imgl1.gx) $generic $(GFLAGS) imgl1.gx $endif + $ifolder (tf/imggsr.x, imggs.gx) $generic $(GFLAGS) imggs.gx $endif + $ifolder (tf/imflsr.x, imfls.gx) $generic $(GFLAGS) imfls.gx $endif + ; + +libex.a: + # Retranslate any recently modified generic sources. + $ifeq (hostid, unix) + $call tfiles + $endif + + @tf # Update datatype expanded files. + @db # Update image database interface. + @dbc # Update image database interface (enhanced). + @iki # Update image kernel interface. + @imt # Update the image template package. + #imt.x + + imaccess.x + imaflp.x + imaplv.x <imhdr.h> <imio.h> + imbln1.x <imhdr.h> <imio.h> + imbln2.x <imhdr.h> <imio.h> + imbln3.x <imhdr.h> <imio.h> + imbtran.x <imhdr.h> <imio.h> <imset.h> + imcopy.x + imcssz.x <imhdr.h> <imio.h> <plset.h> + imdelete.x + imdmap.x <error.h> <imhdr.h> <imio.h> <imset.h> + imerr.x + imflsh.x <imhdr.h> <imio.h> + imflush.x <imhdr.h> <imio.h> + imgclust.x + imggsc.x <imhdr.h> <imio.h> <plset.h> + imgibf.x <imhdr.h> <imio.h> + imgimage.x + imgnln.x <imhdr.h> <imio.h> <szpixtype.inc> + imgobf.x <imhdr.h> <imio.h> + imgsect.x + iminie.x <imhdr.h> <imio.h> + imioff.x <config.h> <imhdr.h> <imio.h> <mach.h> <szpixtype.inc> + imisec.x <ctype.h> <imhdr.h> <imio.h> <mach.h> + imloop.x <imio.h> + immaky.x <error.h> <imhdr.h> <imio.h> + immap.x + immapz.x <error.h> <imhdr.h> <imio.h> <mach.h> + imnote.x <imhdr.h> <imio.h> <szpixtype.inc> + imopsf.x <fset.h> <imhdr.h> <imio.h> <plset.h> <pmset.h> + imparse.x <ctype.h> + impmhdr.x <ctype.h> <imhdr.h> <imio.h> + impmlne1.x <imhdr.h> <imio.h> + impmlne2.x <imhdr.h> <imio.h> + impmlne3.x <imhdr.h> <imio.h> + impmlnev.x <imhdr.h> <imio.h> + impmmap.x <error.h> <imhdr.h> <imio.h> <pmset.h> + impmmapo.x <imhdr.h> <imio.h> <plio.h> <pmset.h> + impmopen.x <error.h> <imhdr.h> <imio.h> <pmset.h> + impmsne1.x <imio.h> + impmsne2.x <imio.h> + impmsne3.x <imio.h> + impmsnev.x <imhdr.h> <imio.h> + impnln.x <imhdr.h> <imio.h> <szpixtype.inc> + imrbpx.x <imhdr.h> <imio.h> <imset.h> <szpixtype.inc> + imrdpx.x <imhdr.h> <imio.h> <mach.h> <plset.h> <szpixtype.inc> + imrename.x + imrmbufs.x <imio.h> + imsamp.x + imsetbuf.x <fset.h> <imhdr.h> <imio.h> + imseti.x <fset.h> <imhdr.h> <imio.h> <imset.h> + imsetr.x <imhdr.h> <imio.h> <imset.h> + imsinb.x <imhdr.h> <imio.h> + imsslv.x <imhdr.h> <imio.h> + imstati.x <imhdr.h> <imio.h> <imset.h> + imstatr.x <imhdr.h> <imio.h> <imset.h> + imstats.x <imhdr.h> <imio.h> <imset.h> + imunmap.x <imhdr.h> <imio.h> + imwbpx.x <imhdr.h> <imio.h> <imset.h> <szpixtype.inc> + imwrite.x <fset.h> <imio.h> + imwrpx.x <imhdr.h> <imio.h> <mach.h> <plset.h> <szpixtype.inc> + zzdebug.x + ; diff --git a/sys/imio/tf/imflsd.x b/sys/imio/tf/imflsd.x new file mode 100644 index 00000000..bc12f5b5 --- /dev/null +++ b/sys/imio/tf/imflsd.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> + +# IMFLS? -- Flush the output buffer, if necessary. Convert the datatype +# of the pixels upon output, if the datatype of the pixels in the imagefile +# is different than that requested by the calling program. + +procedure imflsd (imdes) + +pointer imdes +pointer bdes, bp +errchk imflsh + +begin + # Ignore the flush request if the output buffer has already been + # flushed. + + if (IM_FLUSH(imdes) == YES) { + bdes = IM_OBDES(imdes) + bp = BD_BUFPTR(bdes) + + # Convert datatype of pixels, if necessary, and flush buffer. + if (IM_PIXTYPE(imdes) != TY_DOUBLE || SZ_INT != SZ_INT32) { + call impakd (Memc[bp], Memc[bp], BD_NPIX(bdes), + IM_PIXTYPE(imdes)) + } + + call imflsh (imdes, bp, BD_VS(bdes,1), BD_VE(bdes,1), BD_NDIM(bdes)) + + IM_FLUSH(imdes) = NO + } +end diff --git a/sys/imio/tf/imflsi.x b/sys/imio/tf/imflsi.x new file mode 100644 index 00000000..b7a4b4fb --- /dev/null +++ b/sys/imio/tf/imflsi.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> + +# IMFLS? -- Flush the output buffer, if necessary. Convert the datatype +# of the pixels upon output, if the datatype of the pixels in the imagefile +# is different than that requested by the calling program. + +procedure imflsi (imdes) + +pointer imdes +pointer bdes, bp +errchk imflsh + +begin + # Ignore the flush request if the output buffer has already been + # flushed. + + if (IM_FLUSH(imdes) == YES) { + bdes = IM_OBDES(imdes) + bp = BD_BUFPTR(bdes) + + # Convert datatype of pixels, if necessary, and flush buffer. + if (IM_PIXTYPE(imdes) != TY_INT || SZ_INT != SZ_INT32) { + call impaki (Memc[bp], Memc[bp], BD_NPIX(bdes), + IM_PIXTYPE(imdes)) + } + + call imflsh (imdes, bp, BD_VS(bdes,1), BD_VE(bdes,1), BD_NDIM(bdes)) + + IM_FLUSH(imdes) = NO + } +end diff --git a/sys/imio/tf/imflsl.x b/sys/imio/tf/imflsl.x new file mode 100644 index 00000000..26934cb1 --- /dev/null +++ b/sys/imio/tf/imflsl.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> + +# IMFLS? -- Flush the output buffer, if necessary. Convert the datatype +# of the pixels upon output, if the datatype of the pixels in the imagefile +# is different than that requested by the calling program. + +procedure imflsl (imdes) + +pointer imdes +pointer bdes, bp +errchk imflsh + +begin + # Ignore the flush request if the output buffer has already been + # flushed. + + if (IM_FLUSH(imdes) == YES) { + bdes = IM_OBDES(imdes) + bp = BD_BUFPTR(bdes) + + # Convert datatype of pixels, if necessary, and flush buffer. + if (IM_PIXTYPE(imdes) != TY_LONG || SZ_INT != SZ_INT32) { + call impakl (Memc[bp], Memc[bp], BD_NPIX(bdes), + IM_PIXTYPE(imdes)) + } + + call imflsh (imdes, bp, BD_VS(bdes,1), BD_VE(bdes,1), BD_NDIM(bdes)) + + IM_FLUSH(imdes) = NO + } +end diff --git a/sys/imio/tf/imflsr.x b/sys/imio/tf/imflsr.x new file mode 100644 index 00000000..b19f1bcc --- /dev/null +++ b/sys/imio/tf/imflsr.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> + +# IMFLS? -- Flush the output buffer, if necessary. Convert the datatype +# of the pixels upon output, if the datatype of the pixels in the imagefile +# is different than that requested by the calling program. + +procedure imflsr (imdes) + +pointer imdes +pointer bdes, bp +errchk imflsh + +begin + # Ignore the flush request if the output buffer has already been + # flushed. + + if (IM_FLUSH(imdes) == YES) { + bdes = IM_OBDES(imdes) + bp = BD_BUFPTR(bdes) + + # Convert datatype of pixels, if necessary, and flush buffer. + if (IM_PIXTYPE(imdes) != TY_REAL || SZ_INT != SZ_INT32) { + call impakr (Memc[bp], Memc[bp], BD_NPIX(bdes), + IM_PIXTYPE(imdes)) + } + + call imflsh (imdes, bp, BD_VS(bdes,1), BD_VE(bdes,1), BD_NDIM(bdes)) + + IM_FLUSH(imdes) = NO + } +end diff --git a/sys/imio/tf/imflss.x b/sys/imio/tf/imflss.x new file mode 100644 index 00000000..1034413b --- /dev/null +++ b/sys/imio/tf/imflss.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> + +# IMFLS? -- Flush the output buffer, if necessary. Convert the datatype +# of the pixels upon output, if the datatype of the pixels in the imagefile +# is different than that requested by the calling program. + +procedure imflss (imdes) + +pointer imdes +pointer bdes, bp +errchk imflsh + +begin + # Ignore the flush request if the output buffer has already been + # flushed. + + if (IM_FLUSH(imdes) == YES) { + bdes = IM_OBDES(imdes) + bp = BD_BUFPTR(bdes) + + # Convert datatype of pixels, if necessary, and flush buffer. + if (IM_PIXTYPE(imdes) != TY_SHORT || SZ_INT != SZ_INT32) { + call impaks (Memc[bp], Memc[bp], BD_NPIX(bdes), + IM_PIXTYPE(imdes)) + } + + call imflsh (imdes, bp, BD_VS(bdes,1), BD_VE(bdes,1), BD_NDIM(bdes)) + + IM_FLUSH(imdes) = NO + } +end diff --git a/sys/imio/tf/imflsx.x b/sys/imio/tf/imflsx.x new file mode 100644 index 00000000..7e847ffe --- /dev/null +++ b/sys/imio/tf/imflsx.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> + +# IMFLS? -- Flush the output buffer, if necessary. Convert the datatype +# of the pixels upon output, if the datatype of the pixels in the imagefile +# is different than that requested by the calling program. + +procedure imflsx (imdes) + +pointer imdes +pointer bdes, bp +errchk imflsh + +begin + # Ignore the flush request if the output buffer has already been + # flushed. + + if (IM_FLUSH(imdes) == YES) { + bdes = IM_OBDES(imdes) + bp = BD_BUFPTR(bdes) + + # Convert datatype of pixels, if necessary, and flush buffer. + if (IM_PIXTYPE(imdes) != TY_COMPLEX || SZ_INT != SZ_INT32) { + call impakx (Memc[bp], Memc[bp], BD_NPIX(bdes), + IM_PIXTYPE(imdes)) + } + + call imflsh (imdes, bp, BD_VS(bdes,1), BD_VE(bdes,1), BD_NDIM(bdes)) + + IM_FLUSH(imdes) = NO + } +end diff --git a/sys/imio/tf/imggsd.x b/sys/imio/tf/imggsd.x new file mode 100644 index 00000000..509da31b --- /dev/null +++ b/sys/imio/tf/imggsd.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMGGS? -- Get a general section. + +pointer procedure imggsd (imdes, vs, ve, ndim) + +pointer imdes +long vs[IM_MAXDIM], ve[IM_MAXDIM] +int ndim +long totpix +pointer bp, imggsc() +errchk imggsc + +begin + bp = imggsc (imdes, vs, ve, ndim, TY_DOUBLE, totpix) + if (IM_PIXTYPE(imdes) != TY_DOUBLE) + call imupkd (Memd[bp], Memd[bp], totpix, IM_PIXTYPE(imdes)) + return (bp) +end diff --git a/sys/imio/tf/imggsi.x b/sys/imio/tf/imggsi.x new file mode 100644 index 00000000..9cd0e00c --- /dev/null +++ b/sys/imio/tf/imggsi.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMGGS? -- Get a general section. + +pointer procedure imggsi (imdes, vs, ve, ndim) + +pointer imdes +long vs[IM_MAXDIM], ve[IM_MAXDIM] +int ndim +long totpix +pointer bp, imggsc() +errchk imggsc + +begin + bp = imggsc (imdes, vs, ve, ndim, TY_INT, totpix) + if (IM_PIXTYPE(imdes) != TY_INT) + call imupki (Memi[bp], Memi[bp], totpix, IM_PIXTYPE(imdes)) + return (bp) +end diff --git a/sys/imio/tf/imggsl.x b/sys/imio/tf/imggsl.x new file mode 100644 index 00000000..e4d2411d --- /dev/null +++ b/sys/imio/tf/imggsl.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMGGS? -- Get a general section. + +pointer procedure imggsl (imdes, vs, ve, ndim) + +pointer imdes +long vs[IM_MAXDIM], ve[IM_MAXDIM] +int ndim +long totpix +pointer bp, imggsc() +errchk imggsc + +begin + bp = imggsc (imdes, vs, ve, ndim, TY_LONG, totpix) + if (IM_PIXTYPE(imdes) != TY_LONG) + call imupkl (Meml[bp], Meml[bp], totpix, IM_PIXTYPE(imdes)) + return (bp) +end diff --git a/sys/imio/tf/imggsr.x b/sys/imio/tf/imggsr.x new file mode 100644 index 00000000..37055497 --- /dev/null +++ b/sys/imio/tf/imggsr.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMGGS? -- Get a general section. + +pointer procedure imggsr (imdes, vs, ve, ndim) + +pointer imdes +long vs[IM_MAXDIM], ve[IM_MAXDIM] +int ndim +long totpix +pointer bp, imggsc() +errchk imggsc + +begin + bp = imggsc (imdes, vs, ve, ndim, TY_REAL, totpix) + if (IM_PIXTYPE(imdes) != TY_REAL) + call imupkr (Memr[bp], Memr[bp], totpix, IM_PIXTYPE(imdes)) + return (bp) +end diff --git a/sys/imio/tf/imggss.x b/sys/imio/tf/imggss.x new file mode 100644 index 00000000..f6e3260e --- /dev/null +++ b/sys/imio/tf/imggss.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMGGS? -- Get a general section. + +pointer procedure imggss (imdes, vs, ve, ndim) + +pointer imdes +long vs[IM_MAXDIM], ve[IM_MAXDIM] +int ndim +long totpix +pointer bp, imggsc() +errchk imggsc + +begin + bp = imggsc (imdes, vs, ve, ndim, TY_SHORT, totpix) + if (IM_PIXTYPE(imdes) != TY_SHORT) + call imupks (Mems[bp], Mems[bp], totpix, IM_PIXTYPE(imdes)) + return (bp) +end diff --git a/sys/imio/tf/imggsx.x b/sys/imio/tf/imggsx.x new file mode 100644 index 00000000..60c029c0 --- /dev/null +++ b/sys/imio/tf/imggsx.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMGGS? -- Get a general section. + +pointer procedure imggsx (imdes, vs, ve, ndim) + +pointer imdes +long vs[IM_MAXDIM], ve[IM_MAXDIM] +int ndim +long totpix +pointer bp, imggsc() +errchk imggsc + +begin + bp = imggsc (imdes, vs, ve, ndim, TY_COMPLEX, totpix) + if (IM_PIXTYPE(imdes) != TY_COMPLEX) + call imupkx (Memx[bp], Memx[bp], totpix, IM_PIXTYPE(imdes)) + return (bp) +end diff --git a/sys/imio/tf/imgl1d.x b/sys/imio/tf/imgl1d.x new file mode 100644 index 00000000..eeab8586 --- /dev/null +++ b/sys/imio/tf/imgl1d.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> + +# IMGL1? -- Get a line from an apparently one dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure imgl1d (im) + +pointer im +int fd, nchars +long offset +pointer bp, imggsd(), freadp() +errchk imopsf + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_DOUBLE) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + + offset = IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_DOUBLE + ifnoerr (bp = (freadp (fd, offset, nchars) - 1) / SZ_DOUBLE + 1) + return (bp) + } + return (imggsd (im, long(1), IM_LEN(im,1), 1)) + } +end diff --git a/sys/imio/tf/imgl1i.x b/sys/imio/tf/imgl1i.x new file mode 100644 index 00000000..0de66fa2 --- /dev/null +++ b/sys/imio/tf/imgl1i.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> + +# IMGL1? -- Get a line from an apparently one dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure imgl1i (im) + +pointer im +int fd, nchars +long offset +pointer bp, imggsi(), freadp() +errchk imopsf + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_INT) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + + offset = IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_INT + ifnoerr (bp = (freadp (fd, offset, nchars) - 1) / SZ_INT + 1) + return (bp) + } + return (imggsi (im, long(1), IM_LEN(im,1), 1)) + } +end diff --git a/sys/imio/tf/imgl1l.x b/sys/imio/tf/imgl1l.x new file mode 100644 index 00000000..a996ce32 --- /dev/null +++ b/sys/imio/tf/imgl1l.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> + +# IMGL1? -- Get a line from an apparently one dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure imgl1l (im) + +pointer im +int fd, nchars +long offset +pointer bp, imggsl(), freadp() +errchk imopsf + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_LONG) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + + offset = IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_LONG + ifnoerr (bp = (freadp (fd, offset, nchars) - 1) / SZ_LONG + 1) + return (bp) + } + return (imggsl (im, long(1), IM_LEN(im,1), 1)) + } +end diff --git a/sys/imio/tf/imgl1r.x b/sys/imio/tf/imgl1r.x new file mode 100644 index 00000000..a3f20de8 --- /dev/null +++ b/sys/imio/tf/imgl1r.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> + +# IMGL1? -- Get a line from an apparently one dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure imgl1r (im) + +pointer im +int fd, nchars +long offset +pointer bp, imggsr(), freadp() +errchk imopsf + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_REAL) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + + offset = IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_REAL + ifnoerr (bp = (freadp (fd, offset, nchars) - 1) / SZ_REAL + 1) + return (bp) + } + return (imggsr (im, long(1), IM_LEN(im,1), 1)) + } +end diff --git a/sys/imio/tf/imgl1s.x b/sys/imio/tf/imgl1s.x new file mode 100644 index 00000000..bd226f31 --- /dev/null +++ b/sys/imio/tf/imgl1s.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> + +# IMGL1? -- Get a line from an apparently one dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure imgl1s (im) + +pointer im +int fd, nchars +long offset +pointer bp, imggss(), freadp() +errchk imopsf + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_SHORT) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + + offset = IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_SHORT + ifnoerr (bp = (freadp (fd, offset, nchars) - 1) / SZ_SHORT + 1) + return (bp) + } + return (imggss (im, long(1), IM_LEN(im,1), 1)) + } +end diff --git a/sys/imio/tf/imgl1x.x b/sys/imio/tf/imgl1x.x new file mode 100644 index 00000000..a7f73ac1 --- /dev/null +++ b/sys/imio/tf/imgl1x.x @@ -0,0 +1,35 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> + +# IMGL1? -- Get a line from an apparently one dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure imgl1x (im) + +pointer im +int fd, nchars +long offset +pointer bp, imggsx(), freadp() +errchk imopsf + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_COMPLEX) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + + offset = IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_COMPLEX + ifnoerr (bp = (freadp (fd, offset, nchars) - 1) / SZ_COMPLEX + 1) + return (bp) + } + return (imggsx (im, long(1), IM_LEN(im,1), 1)) + } +end diff --git a/sys/imio/tf/imgl2d.x b/sys/imio/tf/imgl2d.x new file mode 100644 index 00000000..dbd7858a --- /dev/null +++ b/sys/imio/tf/imgl2d.x @@ -0,0 +1,47 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include <imio.h> + +# IMGL2? -- Get a line from an apparently two dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure imgl2d (im, linenum) + +pointer im # image header pointer +int linenum # line to be read + +int fd, nchars +long vs[2], ve[2], offset +pointer bp, imggsd(), freadp() +errchk imopsf, imerr + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_DOUBLE) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + if (linenum < 1 || linenum > IM_LEN(im,2)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + offset = (linenum - 1) * IM_PHYSLEN(im,1) * SZ_DOUBLE + + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_DOUBLE + ifnoerr (bp = (freadp (fd, offset, nchars) - 1) / SZ_DOUBLE + 1) + return (bp) + } + + vs[1] = 1 + ve[1] = IM_LEN(im,1) + vs[2] = linenum + ve[2] = linenum + + return (imggsd (im, vs, ve, 2)) + } +end diff --git a/sys/imio/tf/imgl2i.x b/sys/imio/tf/imgl2i.x new file mode 100644 index 00000000..9592ebe9 --- /dev/null +++ b/sys/imio/tf/imgl2i.x @@ -0,0 +1,47 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include <imio.h> + +# IMGL2? -- Get a line from an apparently two dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure imgl2i (im, linenum) + +pointer im # image header pointer +int linenum # line to be read + +int fd, nchars +long vs[2], ve[2], offset +pointer bp, imggsi(), freadp() +errchk imopsf, imerr + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_INT) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + if (linenum < 1 || linenum > IM_LEN(im,2)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + offset = (linenum - 1) * IM_PHYSLEN(im,1) * SZ_INT + + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_INT + ifnoerr (bp = (freadp (fd, offset, nchars) - 1) / SZ_INT + 1) + return (bp) + } + + vs[1] = 1 + ve[1] = IM_LEN(im,1) + vs[2] = linenum + ve[2] = linenum + + return (imggsi (im, vs, ve, 2)) + } +end diff --git a/sys/imio/tf/imgl2l.x b/sys/imio/tf/imgl2l.x new file mode 100644 index 00000000..e3f5d523 --- /dev/null +++ b/sys/imio/tf/imgl2l.x @@ -0,0 +1,47 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include <imio.h> + +# IMGL2? -- Get a line from an apparently two dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure imgl2l (im, linenum) + +pointer im # image header pointer +int linenum # line to be read + +int fd, nchars +long vs[2], ve[2], offset +pointer bp, imggsl(), freadp() +errchk imopsf, imerr + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_LONG) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + if (linenum < 1 || linenum > IM_LEN(im,2)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + offset = (linenum - 1) * IM_PHYSLEN(im,1) * SZ_LONG + + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_LONG + ifnoerr (bp = (freadp (fd, offset, nchars) - 1) / SZ_LONG + 1) + return (bp) + } + + vs[1] = 1 + ve[1] = IM_LEN(im,1) + vs[2] = linenum + ve[2] = linenum + + return (imggsl (im, vs, ve, 2)) + } +end diff --git a/sys/imio/tf/imgl2r.x b/sys/imio/tf/imgl2r.x new file mode 100644 index 00000000..d487e61b --- /dev/null +++ b/sys/imio/tf/imgl2r.x @@ -0,0 +1,47 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include <imio.h> + +# IMGL2? -- Get a line from an apparently two dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure imgl2r (im, linenum) + +pointer im # image header pointer +int linenum # line to be read + +int fd, nchars +long vs[2], ve[2], offset +pointer bp, imggsr(), freadp() +errchk imopsf, imerr + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_REAL) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + if (linenum < 1 || linenum > IM_LEN(im,2)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + offset = (linenum - 1) * IM_PHYSLEN(im,1) * SZ_REAL + + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_REAL + ifnoerr (bp = (freadp (fd, offset, nchars) - 1) / SZ_REAL + 1) + return (bp) + } + + vs[1] = 1 + ve[1] = IM_LEN(im,1) + vs[2] = linenum + ve[2] = linenum + + return (imggsr (im, vs, ve, 2)) + } +end diff --git a/sys/imio/tf/imgl2s.x b/sys/imio/tf/imgl2s.x new file mode 100644 index 00000000..a4fd140b --- /dev/null +++ b/sys/imio/tf/imgl2s.x @@ -0,0 +1,47 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include <imio.h> + +# IMGL2? -- Get a line from an apparently two dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure imgl2s (im, linenum) + +pointer im # image header pointer +int linenum # line to be read + +int fd, nchars +long vs[2], ve[2], offset +pointer bp, imggss(), freadp() +errchk imopsf, imerr + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_SHORT) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + if (linenum < 1 || linenum > IM_LEN(im,2)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + offset = (linenum - 1) * IM_PHYSLEN(im,1) * SZ_SHORT + + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_SHORT + ifnoerr (bp = (freadp (fd, offset, nchars) - 1) / SZ_SHORT + 1) + return (bp) + } + + vs[1] = 1 + ve[1] = IM_LEN(im,1) + vs[2] = linenum + ve[2] = linenum + + return (imggss (im, vs, ve, 2)) + } +end diff --git a/sys/imio/tf/imgl2x.x b/sys/imio/tf/imgl2x.x new file mode 100644 index 00000000..7a97ac48 --- /dev/null +++ b/sys/imio/tf/imgl2x.x @@ -0,0 +1,47 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include <imio.h> + +# IMGL2? -- Get a line from an apparently two dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure imgl2x (im, linenum) + +pointer im # image header pointer +int linenum # line to be read + +int fd, nchars +long vs[2], ve[2], offset +pointer bp, imggsx(), freadp() +errchk imopsf, imerr + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_COMPLEX) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + if (linenum < 1 || linenum > IM_LEN(im,2)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + offset = (linenum - 1) * IM_PHYSLEN(im,1) * SZ_COMPLEX + + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_COMPLEX + ifnoerr (bp = (freadp (fd, offset, nchars) - 1) / SZ_COMPLEX + 1) + return (bp) + } + + vs[1] = 1 + ve[1] = IM_LEN(im,1) + vs[2] = linenum + ve[2] = linenum + + return (imggsx (im, vs, ve, 2)) + } +end diff --git a/sys/imio/tf/imgl3d.x b/sys/imio/tf/imgl3d.x new file mode 100644 index 00000000..735cc4d1 --- /dev/null +++ b/sys/imio/tf/imgl3d.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include <imio.h> + +# IMGL3? -- Get a line from an apparently three dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure imgl3d (im, line, band) + +pointer im # image header pointer +int line # line number within band +int band # band number + +int fd, nchars +long vs[3], ve[3], offset +pointer bp, imggsd(), freadp() +errchk imopsf, imerr + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_DOUBLE) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + if (line < 1 || line > IM_LEN(im,2) || + band < 1 || band > IM_LEN(im,3)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + offset = (((band - 1) * IM_PHYSLEN(im,2) + line - 1) * + IM_PHYSLEN(im,1)) * SZ_DOUBLE + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_DOUBLE + ifnoerr (bp = (freadp (fd, offset, nchars) - 1) / SZ_DOUBLE + 1) + return (bp) + } + + vs[1] = 1 + ve[1] = IM_LEN(im,1) + vs[2] = line + ve[2] = line + vs[3] = band + ve[3] = band + + return (imggsd (im, vs, ve, 3)) + } +end diff --git a/sys/imio/tf/imgl3i.x b/sys/imio/tf/imgl3i.x new file mode 100644 index 00000000..75a87d36 --- /dev/null +++ b/sys/imio/tf/imgl3i.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include <imio.h> + +# IMGL3? -- Get a line from an apparently three dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure imgl3i (im, line, band) + +pointer im # image header pointer +int line # line number within band +int band # band number + +int fd, nchars +long vs[3], ve[3], offset +pointer bp, imggsi(), freadp() +errchk imopsf, imerr + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_INT) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + if (line < 1 || line > IM_LEN(im,2) || + band < 1 || band > IM_LEN(im,3)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + offset = (((band - 1) * IM_PHYSLEN(im,2) + line - 1) * + IM_PHYSLEN(im,1)) * SZ_INT + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_INT + ifnoerr (bp = (freadp (fd, offset, nchars) - 1) / SZ_INT + 1) + return (bp) + } + + vs[1] = 1 + ve[1] = IM_LEN(im,1) + vs[2] = line + ve[2] = line + vs[3] = band + ve[3] = band + + return (imggsi (im, vs, ve, 3)) + } +end diff --git a/sys/imio/tf/imgl3l.x b/sys/imio/tf/imgl3l.x new file mode 100644 index 00000000..e18f8d3e --- /dev/null +++ b/sys/imio/tf/imgl3l.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include <imio.h> + +# IMGL3? -- Get a line from an apparently three dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure imgl3l (im, line, band) + +pointer im # image header pointer +int line # line number within band +int band # band number + +int fd, nchars +long vs[3], ve[3], offset +pointer bp, imggsl(), freadp() +errchk imopsf, imerr + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_LONG) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + if (line < 1 || line > IM_LEN(im,2) || + band < 1 || band > IM_LEN(im,3)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + offset = (((band - 1) * IM_PHYSLEN(im,2) + line - 1) * + IM_PHYSLEN(im,1)) * SZ_LONG + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_LONG + ifnoerr (bp = (freadp (fd, offset, nchars) - 1) / SZ_LONG + 1) + return (bp) + } + + vs[1] = 1 + ve[1] = IM_LEN(im,1) + vs[2] = line + ve[2] = line + vs[3] = band + ve[3] = band + + return (imggsl (im, vs, ve, 3)) + } +end diff --git a/sys/imio/tf/imgl3r.x b/sys/imio/tf/imgl3r.x new file mode 100644 index 00000000..428e55aa --- /dev/null +++ b/sys/imio/tf/imgl3r.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include <imio.h> + +# IMGL3? -- Get a line from an apparently three dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure imgl3r (im, line, band) + +pointer im # image header pointer +int line # line number within band +int band # band number + +int fd, nchars +long vs[3], ve[3], offset +pointer bp, imggsr(), freadp() +errchk imopsf, imerr + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_REAL) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + if (line < 1 || line > IM_LEN(im,2) || + band < 1 || band > IM_LEN(im,3)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + offset = (((band - 1) * IM_PHYSLEN(im,2) + line - 1) * + IM_PHYSLEN(im,1)) * SZ_REAL + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_REAL + ifnoerr (bp = (freadp (fd, offset, nchars) - 1) / SZ_REAL + 1) + return (bp) + } + + vs[1] = 1 + ve[1] = IM_LEN(im,1) + vs[2] = line + ve[2] = line + vs[3] = band + ve[3] = band + + return (imggsr (im, vs, ve, 3)) + } +end diff --git a/sys/imio/tf/imgl3s.x b/sys/imio/tf/imgl3s.x new file mode 100644 index 00000000..32cd0625 --- /dev/null +++ b/sys/imio/tf/imgl3s.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include <imio.h> + +# IMGL3? -- Get a line from an apparently three dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure imgl3s (im, line, band) + +pointer im # image header pointer +int line # line number within band +int band # band number + +int fd, nchars +long vs[3], ve[3], offset +pointer bp, imggss(), freadp() +errchk imopsf, imerr + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_SHORT) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + if (line < 1 || line > IM_LEN(im,2) || + band < 1 || band > IM_LEN(im,3)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + offset = (((band - 1) * IM_PHYSLEN(im,2) + line - 1) * + IM_PHYSLEN(im,1)) * SZ_SHORT + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_SHORT + ifnoerr (bp = (freadp (fd, offset, nchars) - 1) / SZ_SHORT + 1) + return (bp) + } + + vs[1] = 1 + ve[1] = IM_LEN(im,1) + vs[2] = line + ve[2] = line + vs[3] = band + ve[3] = band + + return (imggss (im, vs, ve, 3)) + } +end diff --git a/sys/imio/tf/imgl3x.x b/sys/imio/tf/imgl3x.x new file mode 100644 index 00000000..9ba1052d --- /dev/null +++ b/sys/imio/tf/imgl3x.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include <imio.h> + +# IMGL3? -- Get a line from an apparently three dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure imgl3x (im, line, band) + +pointer im # image header pointer +int line # line number within band +int band # band number + +int fd, nchars +long vs[3], ve[3], offset +pointer bp, imggsx(), freadp() +errchk imopsf, imerr + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_COMPLEX) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + if (line < 1 || line > IM_LEN(im,2) || + band < 1 || band > IM_LEN(im,3)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + offset = (((band - 1) * IM_PHYSLEN(im,2) + line - 1) * + IM_PHYSLEN(im,1)) * SZ_COMPLEX + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_COMPLEX + ifnoerr (bp = (freadp (fd, offset, nchars) - 1) / SZ_COMPLEX + 1) + return (bp) + } + + vs[1] = 1 + ve[1] = IM_LEN(im,1) + vs[2] = line + ve[2] = line + vs[3] = band + ve[3] = band + + return (imggsx (im, vs, ve, 3)) + } +end diff --git a/sys/imio/tf/imgnld.x b/sys/imio/tf/imgnld.x new file mode 100644 index 00000000..55b27360 --- /dev/null +++ b/sys/imio/tf/imgnld.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMGNL -- Get the next line from an image of any dimension or datatype. +# This is a sequential operator. The index vector V should be initialized +# to the first line to be read before the first call. Each call increments +# the leftmost subscript by one, until V equals IM_LEN, at which time EOF +# is returned. + +int procedure imgnld (imdes, lineptr, v) + +pointer imdes +pointer lineptr # on output, points to the pixels +long v[IM_MAXDIM] # loop counter +int npix, dtype, imgnln() +errchk imgnln + +begin + npix = imgnln (imdes, lineptr, v, TY_DOUBLE) + + if (npix != EOF) { + dtype = IM_PIXTYPE(imdes) + if (dtype != TY_DOUBLE) + call imupkd (Memd[lineptr], Memd[lineptr], npix, dtype) + } + + return (npix) +end diff --git a/sys/imio/tf/imgnli.x b/sys/imio/tf/imgnli.x new file mode 100644 index 00000000..1b9ed846 --- /dev/null +++ b/sys/imio/tf/imgnli.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMGNL -- Get the next line from an image of any dimension or datatype. +# This is a sequential operator. The index vector V should be initialized +# to the first line to be read before the first call. Each call increments +# the leftmost subscript by one, until V equals IM_LEN, at which time EOF +# is returned. + +int procedure imgnli (imdes, lineptr, v) + +pointer imdes +pointer lineptr # on output, points to the pixels +long v[IM_MAXDIM] # loop counter +int npix, dtype, imgnln() +errchk imgnln + +begin + npix = imgnln (imdes, lineptr, v, TY_INT) + + if (npix != EOF) { + dtype = IM_PIXTYPE(imdes) + if (dtype != TY_INT) + call imupki (Memi[lineptr], Memi[lineptr], npix, dtype) + } + + return (npix) +end diff --git a/sys/imio/tf/imgnll.x b/sys/imio/tf/imgnll.x new file mode 100644 index 00000000..81c4fc44 --- /dev/null +++ b/sys/imio/tf/imgnll.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMGNL -- Get the next line from an image of any dimension or datatype. +# This is a sequential operator. The index vector V should be initialized +# to the first line to be read before the first call. Each call increments +# the leftmost subscript by one, until V equals IM_LEN, at which time EOF +# is returned. + +int procedure imgnll (imdes, lineptr, v) + +pointer imdes +pointer lineptr # on output, points to the pixels +long v[IM_MAXDIM] # loop counter +int npix, dtype, imgnln() +errchk imgnln + +begin + npix = imgnln (imdes, lineptr, v, TY_LONG) + + if (npix != EOF) { + dtype = IM_PIXTYPE(imdes) + if (dtype != TY_LONG) + call imupkl (Meml[lineptr], Meml[lineptr], npix, dtype) + } + + return (npix) +end diff --git a/sys/imio/tf/imgnlr.x b/sys/imio/tf/imgnlr.x new file mode 100644 index 00000000..b14c96bb --- /dev/null +++ b/sys/imio/tf/imgnlr.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMGNL -- Get the next line from an image of any dimension or datatype. +# This is a sequential operator. The index vector V should be initialized +# to the first line to be read before the first call. Each call increments +# the leftmost subscript by one, until V equals IM_LEN, at which time EOF +# is returned. + +int procedure imgnlr (imdes, lineptr, v) + +pointer imdes +pointer lineptr # on output, points to the pixels +long v[IM_MAXDIM] # loop counter +int npix, dtype, imgnln() +errchk imgnln + +begin + npix = imgnln (imdes, lineptr, v, TY_REAL) + + if (npix != EOF) { + dtype = IM_PIXTYPE(imdes) + if (dtype != TY_REAL) + call imupkr (Memr[lineptr], Memr[lineptr], npix, dtype) + } + + return (npix) +end diff --git a/sys/imio/tf/imgnls.x b/sys/imio/tf/imgnls.x new file mode 100644 index 00000000..ce962df6 --- /dev/null +++ b/sys/imio/tf/imgnls.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMGNL -- Get the next line from an image of any dimension or datatype. +# This is a sequential operator. The index vector V should be initialized +# to the first line to be read before the first call. Each call increments +# the leftmost subscript by one, until V equals IM_LEN, at which time EOF +# is returned. + +int procedure imgnls (imdes, lineptr, v) + +pointer imdes +pointer lineptr # on output, points to the pixels +long v[IM_MAXDIM] # loop counter +int npix, dtype, imgnln() +errchk imgnln + +begin + npix = imgnln (imdes, lineptr, v, TY_SHORT) + + if (npix != EOF) { + dtype = IM_PIXTYPE(imdes) + if (dtype != TY_SHORT) + call imupks (Mems[lineptr], Mems[lineptr], npix, dtype) + } + + return (npix) +end diff --git a/sys/imio/tf/imgnlx.x b/sys/imio/tf/imgnlx.x new file mode 100644 index 00000000..76075a49 --- /dev/null +++ b/sys/imio/tf/imgnlx.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMGNL -- Get the next line from an image of any dimension or datatype. +# This is a sequential operator. The index vector V should be initialized +# to the first line to be read before the first call. Each call increments +# the leftmost subscript by one, until V equals IM_LEN, at which time EOF +# is returned. + +int procedure imgnlx (imdes, lineptr, v) + +pointer imdes +pointer lineptr # on output, points to the pixels +long v[IM_MAXDIM] # loop counter +int npix, dtype, imgnln() +errchk imgnln + +begin + npix = imgnln (imdes, lineptr, v, TY_COMPLEX) + + if (npix != EOF) { + dtype = IM_PIXTYPE(imdes) + if (dtype != TY_COMPLEX) + call imupkx (Memx[lineptr], Memx[lineptr], npix, dtype) + } + + return (npix) +end diff --git a/sys/imio/tf/imgs1d.x b/sys/imio/tf/imgs1d.x new file mode 100644 index 00000000..5ab52b92 --- /dev/null +++ b/sys/imio/tf/imgs1d.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMGS1? -- Get a section from an apparently one dimensional image. + +pointer procedure imgs1d (im, x1, x2) + +pointer im +int x1, x2 +pointer imggsd(), imgl1d() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1)) + return (imgl1d (im)) + else + return (imggsd (im, long(x1), long(x2), 1)) +end diff --git a/sys/imio/tf/imgs1i.x b/sys/imio/tf/imgs1i.x new file mode 100644 index 00000000..ddb0a435 --- /dev/null +++ b/sys/imio/tf/imgs1i.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMGS1? -- Get a section from an apparently one dimensional image. + +pointer procedure imgs1i (im, x1, x2) + +pointer im +int x1, x2 +pointer imggsi(), imgl1i() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1)) + return (imgl1i (im)) + else + return (imggsi (im, long(x1), long(x2), 1)) +end diff --git a/sys/imio/tf/imgs1l.x b/sys/imio/tf/imgs1l.x new file mode 100644 index 00000000..5f3610c9 --- /dev/null +++ b/sys/imio/tf/imgs1l.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMGS1? -- Get a section from an apparently one dimensional image. + +pointer procedure imgs1l (im, x1, x2) + +pointer im +int x1, x2 +pointer imggsl(), imgl1l() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1)) + return (imgl1l (im)) + else + return (imggsl (im, long(x1), long(x2), 1)) +end diff --git a/sys/imio/tf/imgs1r.x b/sys/imio/tf/imgs1r.x new file mode 100644 index 00000000..9d5da6d4 --- /dev/null +++ b/sys/imio/tf/imgs1r.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMGS1? -- Get a section from an apparently one dimensional image. + +pointer procedure imgs1r (im, x1, x2) + +pointer im +int x1, x2 +pointer imggsr(), imgl1r() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1)) + return (imgl1r (im)) + else + return (imggsr (im, long(x1), long(x2), 1)) +end diff --git a/sys/imio/tf/imgs1s.x b/sys/imio/tf/imgs1s.x new file mode 100644 index 00000000..fc15aac3 --- /dev/null +++ b/sys/imio/tf/imgs1s.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMGS1? -- Get a section from an apparently one dimensional image. + +pointer procedure imgs1s (im, x1, x2) + +pointer im +int x1, x2 +pointer imggss(), imgl1s() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1)) + return (imgl1s (im)) + else + return (imggss (im, long(x1), long(x2), 1)) +end diff --git a/sys/imio/tf/imgs1x.x b/sys/imio/tf/imgs1x.x new file mode 100644 index 00000000..7bb64465 --- /dev/null +++ b/sys/imio/tf/imgs1x.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMGS1? -- Get a section from an apparently one dimensional image. + +pointer procedure imgs1x (im, x1, x2) + +pointer im +int x1, x2 +pointer imggsx(), imgl1x() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1)) + return (imgl1x (im)) + else + return (imggsx (im, long(x1), long(x2), 1)) +end diff --git a/sys/imio/tf/imgs2d.x b/sys/imio/tf/imgs2d.x new file mode 100644 index 00000000..4c8f5f71 --- /dev/null +++ b/sys/imio/tf/imgs2d.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMGS2? -- Get a section from an apparently two dimensional image. + +pointer procedure imgs2d (im, x1, x2, y1, y2) + +pointer im +int x1, x2, y1, y2 +long vs[2], ve[2] +pointer imggsd(), imgl2d() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1) && y1 == y2) + return (imgl2d (im, y1)) + else { + vs[1] = x1 + ve[1] = x2 + + vs[2] = y1 + ve[2] = y2 + + return (imggsd (im, vs, ve, 2)) + } +end diff --git a/sys/imio/tf/imgs2i.x b/sys/imio/tf/imgs2i.x new file mode 100644 index 00000000..fe0c8d1e --- /dev/null +++ b/sys/imio/tf/imgs2i.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMGS2? -- Get a section from an apparently two dimensional image. + +pointer procedure imgs2i (im, x1, x2, y1, y2) + +pointer im +int x1, x2, y1, y2 +long vs[2], ve[2] +pointer imggsi(), imgl2i() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1) && y1 == y2) + return (imgl2i (im, y1)) + else { + vs[1] = x1 + ve[1] = x2 + + vs[2] = y1 + ve[2] = y2 + + return (imggsi (im, vs, ve, 2)) + } +end diff --git a/sys/imio/tf/imgs2l.x b/sys/imio/tf/imgs2l.x new file mode 100644 index 00000000..00fe004e --- /dev/null +++ b/sys/imio/tf/imgs2l.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMGS2? -- Get a section from an apparently two dimensional image. + +pointer procedure imgs2l (im, x1, x2, y1, y2) + +pointer im +int x1, x2, y1, y2 +long vs[2], ve[2] +pointer imggsl(), imgl2l() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1) && y1 == y2) + return (imgl2l (im, y1)) + else { + vs[1] = x1 + ve[1] = x2 + + vs[2] = y1 + ve[2] = y2 + + return (imggsl (im, vs, ve, 2)) + } +end diff --git a/sys/imio/tf/imgs2r.x b/sys/imio/tf/imgs2r.x new file mode 100644 index 00000000..7847908a --- /dev/null +++ b/sys/imio/tf/imgs2r.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMGS2? -- Get a section from an apparently two dimensional image. + +pointer procedure imgs2r (im, x1, x2, y1, y2) + +pointer im +int x1, x2, y1, y2 +long vs[2], ve[2] +pointer imggsr(), imgl2r() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1) && y1 == y2) + return (imgl2r (im, y1)) + else { + vs[1] = x1 + ve[1] = x2 + + vs[2] = y1 + ve[2] = y2 + + return (imggsr (im, vs, ve, 2)) + } +end diff --git a/sys/imio/tf/imgs2s.x b/sys/imio/tf/imgs2s.x new file mode 100644 index 00000000..209debe4 --- /dev/null +++ b/sys/imio/tf/imgs2s.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMGS2? -- Get a section from an apparently two dimensional image. + +pointer procedure imgs2s (im, x1, x2, y1, y2) + +pointer im +int x1, x2, y1, y2 +long vs[2], ve[2] +pointer imggss(), imgl2s() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1) && y1 == y2) + return (imgl2s (im, y1)) + else { + vs[1] = x1 + ve[1] = x2 + + vs[2] = y1 + ve[2] = y2 + + return (imggss (im, vs, ve, 2)) + } +end diff --git a/sys/imio/tf/imgs2x.x b/sys/imio/tf/imgs2x.x new file mode 100644 index 00000000..3ff5bdc4 --- /dev/null +++ b/sys/imio/tf/imgs2x.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMGS2? -- Get a section from an apparently two dimensional image. + +pointer procedure imgs2x (im, x1, x2, y1, y2) + +pointer im +int x1, x2, y1, y2 +long vs[2], ve[2] +pointer imggsx(), imgl2x() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1) && y1 == y2) + return (imgl2x (im, y1)) + else { + vs[1] = x1 + ve[1] = x2 + + vs[2] = y1 + ve[2] = y2 + + return (imggsx (im, vs, ve, 2)) + } +end diff --git a/sys/imio/tf/imgs3d.x b/sys/imio/tf/imgs3d.x new file mode 100644 index 00000000..32c1dab8 --- /dev/null +++ b/sys/imio/tf/imgs3d.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMGS3? -- Get a section from an apparently three dimensional image. + +pointer procedure imgs3d (im, x1, x2, y1, y2, z1, z2) + +pointer im +int x1, x2, y1, y2, z1, z2 +long vs[3], ve[3] +pointer imggsd(), imgl3d() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1) && y1 == y2 && z1 == z2) + return (imgl3d (im, y1, z1)) + else { + vs[1] = x1 + ve[1] = x2 + + vs[2] = y1 + ve[2] = y2 + + vs[3] = z1 + ve[3] = z2 + + return (imggsd (im, vs, ve, 3)) + } +end diff --git a/sys/imio/tf/imgs3i.x b/sys/imio/tf/imgs3i.x new file mode 100644 index 00000000..a231130f --- /dev/null +++ b/sys/imio/tf/imgs3i.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMGS3? -- Get a section from an apparently three dimensional image. + +pointer procedure imgs3i (im, x1, x2, y1, y2, z1, z2) + +pointer im +int x1, x2, y1, y2, z1, z2 +long vs[3], ve[3] +pointer imggsi(), imgl3i() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1) && y1 == y2 && z1 == z2) + return (imgl3i (im, y1, z1)) + else { + vs[1] = x1 + ve[1] = x2 + + vs[2] = y1 + ve[2] = y2 + + vs[3] = z1 + ve[3] = z2 + + return (imggsi (im, vs, ve, 3)) + } +end diff --git a/sys/imio/tf/imgs3l.x b/sys/imio/tf/imgs3l.x new file mode 100644 index 00000000..5f1294b0 --- /dev/null +++ b/sys/imio/tf/imgs3l.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMGS3? -- Get a section from an apparently three dimensional image. + +pointer procedure imgs3l (im, x1, x2, y1, y2, z1, z2) + +pointer im +int x1, x2, y1, y2, z1, z2 +long vs[3], ve[3] +pointer imggsl(), imgl3l() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1) && y1 == y2 && z1 == z2) + return (imgl3l (im, y1, z1)) + else { + vs[1] = x1 + ve[1] = x2 + + vs[2] = y1 + ve[2] = y2 + + vs[3] = z1 + ve[3] = z2 + + return (imggsl (im, vs, ve, 3)) + } +end diff --git a/sys/imio/tf/imgs3r.x b/sys/imio/tf/imgs3r.x new file mode 100644 index 00000000..54bd0667 --- /dev/null +++ b/sys/imio/tf/imgs3r.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMGS3? -- Get a section from an apparently three dimensional image. + +pointer procedure imgs3r (im, x1, x2, y1, y2, z1, z2) + +pointer im +int x1, x2, y1, y2, z1, z2 +long vs[3], ve[3] +pointer imggsr(), imgl3r() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1) && y1 == y2 && z1 == z2) + return (imgl3r (im, y1, z1)) + else { + vs[1] = x1 + ve[1] = x2 + + vs[2] = y1 + ve[2] = y2 + + vs[3] = z1 + ve[3] = z2 + + return (imggsr (im, vs, ve, 3)) + } +end diff --git a/sys/imio/tf/imgs3s.x b/sys/imio/tf/imgs3s.x new file mode 100644 index 00000000..b0692edb --- /dev/null +++ b/sys/imio/tf/imgs3s.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMGS3? -- Get a section from an apparently three dimensional image. + +pointer procedure imgs3s (im, x1, x2, y1, y2, z1, z2) + +pointer im +int x1, x2, y1, y2, z1, z2 +long vs[3], ve[3] +pointer imggss(), imgl3s() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1) && y1 == y2 && z1 == z2) + return (imgl3s (im, y1, z1)) + else { + vs[1] = x1 + ve[1] = x2 + + vs[2] = y1 + ve[2] = y2 + + vs[3] = z1 + ve[3] = z2 + + return (imggss (im, vs, ve, 3)) + } +end diff --git a/sys/imio/tf/imgs3x.x b/sys/imio/tf/imgs3x.x new file mode 100644 index 00000000..f621fe4c --- /dev/null +++ b/sys/imio/tf/imgs3x.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMGS3? -- Get a section from an apparently three dimensional image. + +pointer procedure imgs3x (im, x1, x2, y1, y2, z1, z2) + +pointer im +int x1, x2, y1, y2, z1, z2 +long vs[3], ve[3] +pointer imggsx(), imgl3x() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1) && y1 == y2 && z1 == z2) + return (imgl3x (im, y1, z1)) + else { + vs[1] = x1 + ve[1] = x2 + + vs[2] = y1 + ve[2] = y2 + + vs[3] = z1 + ve[3] = z2 + + return (imggsx (im, vs, ve, 3)) + } +end diff --git a/sys/imio/tf/impakd.x b/sys/imio/tf/impakd.x new file mode 100644 index 00000000..060ef4d5 --- /dev/null +++ b/sys/imio/tf/impakd.x @@ -0,0 +1,46 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMPAK? -- Convert an array of pixels of a specific datatype to the +# datatype given as the final argument. + +procedure impakd (a, b, npix, dtype) + +double a[npix] +int b[npix], npix, dtype + +pointer bp + +begin + switch (dtype) { + case TY_USHORT: + call achtdu (a, b, npix) + case TY_SHORT: + call achtds (a, b, npix) + case TY_INT: + if (SZ_INT == SZ_INT32) + call achtdi (a, b, npix) + else { + call malloc (bp, npix, TY_INT) + call achtdi (a, Memi[bp], npix) + call ipak32 (Memi[bp], b, npix) + call mfree (bp, TY_INT) + } + case TY_LONG: + if (SZ_INT == SZ_INT32) + call achtdl (a, b, npix) + else { + call malloc (bp, npix, TY_LONG) + call achtdl (a, Meml[bp], npix) + call ipak32 (Meml[bp], b, npix) + call mfree (bp, TY_LONG) + } + case TY_REAL: + call achtdr (a, b, npix) + case TY_DOUBLE: + call achtdd (a, b, npix) + case TY_COMPLEX: + call achtdx (a, b, npix) + default: + call error (1, "Unknown datatype in imagefile") + } +end diff --git a/sys/imio/tf/impaki.x b/sys/imio/tf/impaki.x new file mode 100644 index 00000000..5d197add --- /dev/null +++ b/sys/imio/tf/impaki.x @@ -0,0 +1,46 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMPAK? -- Convert an array of pixels of a specific datatype to the +# datatype given as the final argument. + +procedure impaki (a, b, npix, dtype) + +int a[npix] +int b[npix], npix, dtype + +pointer bp + +begin + switch (dtype) { + case TY_USHORT: + call achtiu (a, b, npix) + case TY_SHORT: + call achtis (a, b, npix) + case TY_INT: + if (SZ_INT == SZ_INT32) + call achtii (a, b, npix) + else { + call malloc (bp, npix, TY_INT) + call achtii (a, Memi[bp], npix) + call ipak32 (Memi[bp], b, npix) + call mfree (bp, TY_INT) + } + case TY_LONG: + if (SZ_INT == SZ_INT32) + call achtil (a, b, npix) + else { + call malloc (bp, npix, TY_LONG) + call achtil (a, Meml[bp], npix) + call ipak32 (Meml[bp], b, npix) + call mfree (bp, TY_LONG) + } + case TY_REAL: + call achtir (a, b, npix) + case TY_DOUBLE: + call achtid (a, b, npix) + case TY_COMPLEX: + call achtix (a, b, npix) + default: + call error (1, "Unknown datatype in imagefile") + } +end diff --git a/sys/imio/tf/impakl.x b/sys/imio/tf/impakl.x new file mode 100644 index 00000000..884f931b --- /dev/null +++ b/sys/imio/tf/impakl.x @@ -0,0 +1,46 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMPAK? -- Convert an array of pixels of a specific datatype to the +# datatype given as the final argument. + +procedure impakl (a, b, npix, dtype) + +long a[npix] +int b[npix], npix, dtype + +pointer bp + +begin + switch (dtype) { + case TY_USHORT: + call achtlu (a, b, npix) + case TY_SHORT: + call achtls (a, b, npix) + case TY_INT: + if (SZ_INT == SZ_INT32) + call achtli (a, b, npix) + else { + call malloc (bp, npix, TY_INT) + call achtli (a, Memi[bp], npix) + call ipak32 (Memi[bp], b, npix) + call mfree (bp, TY_INT) + } + case TY_LONG: + if (SZ_INT == SZ_INT32) + call achtll (a, b, npix) + else { + call malloc (bp, npix, TY_LONG) + call achtll (a, Meml[bp], npix) + call ipak32 (Meml[bp], b, npix) + call mfree (bp, TY_LONG) + } + case TY_REAL: + call achtlr (a, b, npix) + case TY_DOUBLE: + call achtld (a, b, npix) + case TY_COMPLEX: + call achtlx (a, b, npix) + default: + call error (1, "Unknown datatype in imagefile") + } +end diff --git a/sys/imio/tf/impakr.x b/sys/imio/tf/impakr.x new file mode 100644 index 00000000..867554ce --- /dev/null +++ b/sys/imio/tf/impakr.x @@ -0,0 +1,46 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMPAK? -- Convert an array of pixels of a specific datatype to the +# datatype given as the final argument. + +procedure impakr (a, b, npix, dtype) + +real a[npix] +int b[npix], npix, dtype + +pointer bp + +begin + switch (dtype) { + case TY_USHORT: + call achtru (a, b, npix) + case TY_SHORT: + call achtrs (a, b, npix) + case TY_INT: + if (SZ_INT == SZ_INT32) + call achtri (a, b, npix) + else { + call malloc (bp, npix, TY_INT) + call achtri (a, Memi[bp], npix) + call ipak32 (Memi[bp], b, npix) + call mfree (bp, TY_INT) + } + case TY_LONG: + if (SZ_INT == SZ_INT32) + call achtrl (a, b, npix) + else { + call malloc (bp, npix, TY_LONG) + call achtrl (a, Meml[bp], npix) + call ipak32 (Meml[bp], b, npix) + call mfree (bp, TY_LONG) + } + case TY_REAL: + call achtrr (a, b, npix) + case TY_DOUBLE: + call achtrd (a, b, npix) + case TY_COMPLEX: + call achtrx (a, b, npix) + default: + call error (1, "Unknown datatype in imagefile") + } +end diff --git a/sys/imio/tf/impaks.x b/sys/imio/tf/impaks.x new file mode 100644 index 00000000..40168707 --- /dev/null +++ b/sys/imio/tf/impaks.x @@ -0,0 +1,46 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMPAK? -- Convert an array of pixels of a specific datatype to the +# datatype given as the final argument. + +procedure impaks (a, b, npix, dtype) + +short a[npix] +int b[npix], npix, dtype + +pointer bp + +begin + switch (dtype) { + case TY_USHORT: + call achtsu (a, b, npix) + case TY_SHORT: + call achtss (a, b, npix) + case TY_INT: + if (SZ_INT == SZ_INT32) + call achtsi (a, b, npix) + else { + call malloc (bp, npix, TY_INT) + call achtsi (a, Memi[bp], npix) + call ipak32 (Memi[bp], b, npix) + call mfree (bp, TY_INT) + } + case TY_LONG: + if (SZ_INT == SZ_INT32) + call achtsl (a, b, npix) + else { + call malloc (bp, npix, TY_LONG) + call achtsl (a, Meml[bp], npix) + call ipak32 (Meml[bp], b, npix) + call mfree (bp, TY_LONG) + } + case TY_REAL: + call achtsr (a, b, npix) + case TY_DOUBLE: + call achtsd (a, b, npix) + case TY_COMPLEX: + call achtsx (a, b, npix) + default: + call error (1, "Unknown datatype in imagefile") + } +end diff --git a/sys/imio/tf/impakx.x b/sys/imio/tf/impakx.x new file mode 100644 index 00000000..1bfcffb9 --- /dev/null +++ b/sys/imio/tf/impakx.x @@ -0,0 +1,46 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMPAK? -- Convert an array of pixels of a specific datatype to the +# datatype given as the final argument. + +procedure impakx (a, b, npix, dtype) + +complex a[npix] +int b[npix], npix, dtype + +pointer bp + +begin + switch (dtype) { + case TY_USHORT: + call achtxu (a, b, npix) + case TY_SHORT: + call achtxs (a, b, npix) + case TY_INT: + if (SZ_INT == SZ_INT32) + call achtxi (a, b, npix) + else { + call malloc (bp, npix, TY_INT) + call achtxi (a, Memi[bp], npix) + call ipak32 (Memi[bp], b, npix) + call mfree (bp, TY_INT) + } + case TY_LONG: + if (SZ_INT == SZ_INT32) + call achtxl (a, b, npix) + else { + call malloc (bp, npix, TY_LONG) + call achtxl (a, Meml[bp], npix) + call ipak32 (Meml[bp], b, npix) + call mfree (bp, TY_LONG) + } + case TY_REAL: + call achtxr (a, b, npix) + case TY_DOUBLE: + call achtxd (a, b, npix) + case TY_COMPLEX: + call achtxx (a, b, npix) + default: + call error (1, "Unknown datatype in imagefile") + } +end diff --git a/sys/imio/tf/impgsd.x b/sys/imio/tf/impgsd.x new file mode 100644 index 00000000..c298816e --- /dev/null +++ b/sys/imio/tf/impgsd.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> + +# IMPGS? -- Put a general section of a specific datatype. + +pointer procedure impgsd (imdes, vs, ve, ndim) + +pointer imdes +long vs[IM_MAXDIM], ve[IM_MAXDIM] +pointer bp, imgobf() +int ndim +extern imflsd() +errchk imflush, imgobf + +begin + # Flush the output buffer, if appropriate. IMFLUSH calls + # one of the IMFLS? routines, which write out the section. + + if (IM_FLUSH(imdes) == YES) + call zcall1 (IM_FLUSHEPA(imdes), imdes) + + # Get an (output) buffer to put the pixels into. Save the + # section parameters in the image descriptor. Save the epa + # of the typed flush procedure in the image descriptor. + + bp = imgobf (imdes, vs, ve, ndim, TY_DOUBLE) + call zlocpr (imflsd, IM_FLUSHEPA(imdes)) + IM_FLUSH(imdes) = YES + + return (bp) +end diff --git a/sys/imio/tf/impgsi.x b/sys/imio/tf/impgsi.x new file mode 100644 index 00000000..62f69105 --- /dev/null +++ b/sys/imio/tf/impgsi.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> + +# IMPGS? -- Put a general section of a specific datatype. + +pointer procedure impgsi (imdes, vs, ve, ndim) + +pointer imdes +long vs[IM_MAXDIM], ve[IM_MAXDIM] +pointer bp, imgobf() +int ndim +extern imflsi() +errchk imflush, imgobf + +begin + # Flush the output buffer, if appropriate. IMFLUSH calls + # one of the IMFLS? routines, which write out the section. + + if (IM_FLUSH(imdes) == YES) + call zcall1 (IM_FLUSHEPA(imdes), imdes) + + # Get an (output) buffer to put the pixels into. Save the + # section parameters in the image descriptor. Save the epa + # of the typed flush procedure in the image descriptor. + + bp = imgobf (imdes, vs, ve, ndim, TY_INT) + call zlocpr (imflsi, IM_FLUSHEPA(imdes)) + IM_FLUSH(imdes) = YES + + return (bp) +end diff --git a/sys/imio/tf/impgsl.x b/sys/imio/tf/impgsl.x new file mode 100644 index 00000000..d791b4fd --- /dev/null +++ b/sys/imio/tf/impgsl.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> + +# IMPGS? -- Put a general section of a specific datatype. + +pointer procedure impgsl (imdes, vs, ve, ndim) + +pointer imdes +long vs[IM_MAXDIM], ve[IM_MAXDIM] +pointer bp, imgobf() +int ndim +extern imflsl() +errchk imflush, imgobf + +begin + # Flush the output buffer, if appropriate. IMFLUSH calls + # one of the IMFLS? routines, which write out the section. + + if (IM_FLUSH(imdes) == YES) + call zcall1 (IM_FLUSHEPA(imdes), imdes) + + # Get an (output) buffer to put the pixels into. Save the + # section parameters in the image descriptor. Save the epa + # of the typed flush procedure in the image descriptor. + + bp = imgobf (imdes, vs, ve, ndim, TY_LONG) + call zlocpr (imflsl, IM_FLUSHEPA(imdes)) + IM_FLUSH(imdes) = YES + + return (bp) +end diff --git a/sys/imio/tf/impgsr.x b/sys/imio/tf/impgsr.x new file mode 100644 index 00000000..46938707 --- /dev/null +++ b/sys/imio/tf/impgsr.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> + +# IMPGS? -- Put a general section of a specific datatype. + +pointer procedure impgsr (imdes, vs, ve, ndim) + +pointer imdes +long vs[IM_MAXDIM], ve[IM_MAXDIM] +pointer bp, imgobf() +int ndim +extern imflsr() +errchk imflush, imgobf + +begin + # Flush the output buffer, if appropriate. IMFLUSH calls + # one of the IMFLS? routines, which write out the section. + + if (IM_FLUSH(imdes) == YES) + call zcall1 (IM_FLUSHEPA(imdes), imdes) + + # Get an (output) buffer to put the pixels into. Save the + # section parameters in the image descriptor. Save the epa + # of the typed flush procedure in the image descriptor. + + bp = imgobf (imdes, vs, ve, ndim, TY_REAL) + call zlocpr (imflsr, IM_FLUSHEPA(imdes)) + IM_FLUSH(imdes) = YES + + return (bp) +end diff --git a/sys/imio/tf/impgss.x b/sys/imio/tf/impgss.x new file mode 100644 index 00000000..bcdf26e0 --- /dev/null +++ b/sys/imio/tf/impgss.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> + +# IMPGS? -- Put a general section of a specific datatype. + +pointer procedure impgss (imdes, vs, ve, ndim) + +pointer imdes +long vs[IM_MAXDIM], ve[IM_MAXDIM] +pointer bp, imgobf() +int ndim +extern imflss() +errchk imflush, imgobf + +begin + # Flush the output buffer, if appropriate. IMFLUSH calls + # one of the IMFLS? routines, which write out the section. + + if (IM_FLUSH(imdes) == YES) + call zcall1 (IM_FLUSHEPA(imdes), imdes) + + # Get an (output) buffer to put the pixels into. Save the + # section parameters in the image descriptor. Save the epa + # of the typed flush procedure in the image descriptor. + + bp = imgobf (imdes, vs, ve, ndim, TY_SHORT) + call zlocpr (imflss, IM_FLUSHEPA(imdes)) + IM_FLUSH(imdes) = YES + + return (bp) +end diff --git a/sys/imio/tf/impgsx.x b/sys/imio/tf/impgsx.x new file mode 100644 index 00000000..bb56c9aa --- /dev/null +++ b/sys/imio/tf/impgsx.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> + +# IMPGS? -- Put a general section of a specific datatype. + +pointer procedure impgsx (imdes, vs, ve, ndim) + +pointer imdes +long vs[IM_MAXDIM], ve[IM_MAXDIM] +pointer bp, imgobf() +int ndim +extern imflsx() +errchk imflush, imgobf + +begin + # Flush the output buffer, if appropriate. IMFLUSH calls + # one of the IMFLS? routines, which write out the section. + + if (IM_FLUSH(imdes) == YES) + call zcall1 (IM_FLUSHEPA(imdes), imdes) + + # Get an (output) buffer to put the pixels into. Save the + # section parameters in the image descriptor. Save the epa + # of the typed flush procedure in the image descriptor. + + bp = imgobf (imdes, vs, ve, ndim, TY_COMPLEX) + call zlocpr (imflsx, IM_FLUSHEPA(imdes)) + IM_FLUSH(imdes) = YES + + return (bp) +end diff --git a/sys/imio/tf/impl1d.x b/sys/imio/tf/impl1d.x new file mode 100644 index 00000000..227d25dd --- /dev/null +++ b/sys/imio/tf/impl1d.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> + +# IMPL1? -- Put a line to an apparently one dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure impl1d (im) + +pointer im # image header pointer +int fd, nchars +long offset +pointer bp, impgsd(), fwritep() +errchk imopsf + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_DOUBLE) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + offset = IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_DOUBLE + ifnoerr (bp = (fwritep (fd, offset, nchars) - 1) / SZ_DOUBLE + 1) + return (bp) + } + return (impgsd (im, long(1), IM_LEN(im,1), 1)) + } +end diff --git a/sys/imio/tf/impl1i.x b/sys/imio/tf/impl1i.x new file mode 100644 index 00000000..a81d6b73 --- /dev/null +++ b/sys/imio/tf/impl1i.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> + +# IMPL1? -- Put a line to an apparently one dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure impl1i (im) + +pointer im # image header pointer +int fd, nchars +long offset +pointer bp, impgsi(), fwritep() +errchk imopsf + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_INT) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + offset = IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_INT + ifnoerr (bp = (fwritep (fd, offset, nchars) - 1) / SZ_INT + 1) + return (bp) + } + return (impgsi (im, long(1), IM_LEN(im,1), 1)) + } +end diff --git a/sys/imio/tf/impl1l.x b/sys/imio/tf/impl1l.x new file mode 100644 index 00000000..8f9616ca --- /dev/null +++ b/sys/imio/tf/impl1l.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> + +# IMPL1? -- Put a line to an apparently one dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure impl1l (im) + +pointer im # image header pointer +int fd, nchars +long offset +pointer bp, impgsl(), fwritep() +errchk imopsf + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_LONG) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + offset = IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_LONG + ifnoerr (bp = (fwritep (fd, offset, nchars) - 1) / SZ_LONG + 1) + return (bp) + } + return (impgsl (im, long(1), IM_LEN(im,1), 1)) + } +end diff --git a/sys/imio/tf/impl1r.x b/sys/imio/tf/impl1r.x new file mode 100644 index 00000000..dc0ed92e --- /dev/null +++ b/sys/imio/tf/impl1r.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> + +# IMPL1? -- Put a line to an apparently one dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure impl1r (im) + +pointer im # image header pointer +int fd, nchars +long offset +pointer bp, impgsr(), fwritep() +errchk imopsf + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_REAL) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + offset = IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_REAL + ifnoerr (bp = (fwritep (fd, offset, nchars) - 1) / SZ_REAL + 1) + return (bp) + } + return (impgsr (im, long(1), IM_LEN(im,1), 1)) + } +end diff --git a/sys/imio/tf/impl1s.x b/sys/imio/tf/impl1s.x new file mode 100644 index 00000000..a598e92a --- /dev/null +++ b/sys/imio/tf/impl1s.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> + +# IMPL1? -- Put a line to an apparently one dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure impl1s (im) + +pointer im # image header pointer +int fd, nchars +long offset +pointer bp, impgss(), fwritep() +errchk imopsf + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_SHORT) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + offset = IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_SHORT + ifnoerr (bp = (fwritep (fd, offset, nchars) - 1) / SZ_SHORT + 1) + return (bp) + } + return (impgss (im, long(1), IM_LEN(im,1), 1)) + } +end diff --git a/sys/imio/tf/impl1x.x b/sys/imio/tf/impl1x.x new file mode 100644 index 00000000..6b141a14 --- /dev/null +++ b/sys/imio/tf/impl1x.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> + +# IMPL1? -- Put a line to an apparently one dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure impl1x (im) + +pointer im # image header pointer +int fd, nchars +long offset +pointer bp, impgsx(), fwritep() +errchk imopsf + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_COMPLEX) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + offset = IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_COMPLEX + ifnoerr (bp = (fwritep (fd, offset, nchars) - 1) / SZ_COMPLEX + 1) + return (bp) + } + return (impgsx (im, long(1), IM_LEN(im,1), 1)) + } +end diff --git a/sys/imio/tf/impl2d.x b/sys/imio/tf/impl2d.x new file mode 100644 index 00000000..cd4a1b6e --- /dev/null +++ b/sys/imio/tf/impl2d.x @@ -0,0 +1,47 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include <imio.h> + +# IMPL2? -- Put a line to an apparently two dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure impl2d (im, linenum) + +pointer im # image header pointer +int linenum # line to be written + +int fd, nchars +long vs[2], ve[2], offset +pointer bp, impgsd(), fwritep() +errchk imopsf, imerr + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_DOUBLE) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + if (linenum < 1 || linenum > IM_LEN(im,2)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + offset = (linenum - 1) * IM_PHYSLEN(im,1) * SZ_DOUBLE + + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_DOUBLE + ifnoerr (bp = (fwritep (fd, offset, nchars) - 1) / SZ_DOUBLE + 1) + return (bp) + } + + vs[1] = 1 + ve[1] = IM_LEN(im,1) + vs[2] = linenum + ve[2] = linenum + + return (impgsd (im, vs, ve, 2)) + } +end diff --git a/sys/imio/tf/impl2i.x b/sys/imio/tf/impl2i.x new file mode 100644 index 00000000..9f13e4ef --- /dev/null +++ b/sys/imio/tf/impl2i.x @@ -0,0 +1,47 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include <imio.h> + +# IMPL2? -- Put a line to an apparently two dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure impl2i (im, linenum) + +pointer im # image header pointer +int linenum # line to be written + +int fd, nchars +long vs[2], ve[2], offset +pointer bp, impgsi(), fwritep() +errchk imopsf, imerr + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_INT) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + if (linenum < 1 || linenum > IM_LEN(im,2)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + offset = (linenum - 1) * IM_PHYSLEN(im,1) * SZ_INT + + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_INT + ifnoerr (bp = (fwritep (fd, offset, nchars) - 1) / SZ_INT + 1) + return (bp) + } + + vs[1] = 1 + ve[1] = IM_LEN(im,1) + vs[2] = linenum + ve[2] = linenum + + return (impgsi (im, vs, ve, 2)) + } +end diff --git a/sys/imio/tf/impl2l.x b/sys/imio/tf/impl2l.x new file mode 100644 index 00000000..c42d57cf --- /dev/null +++ b/sys/imio/tf/impl2l.x @@ -0,0 +1,47 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include <imio.h> + +# IMPL2? -- Put a line to an apparently two dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure impl2l (im, linenum) + +pointer im # image header pointer +int linenum # line to be written + +int fd, nchars +long vs[2], ve[2], offset +pointer bp, impgsl(), fwritep() +errchk imopsf, imerr + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_LONG) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + if (linenum < 1 || linenum > IM_LEN(im,2)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + offset = (linenum - 1) * IM_PHYSLEN(im,1) * SZ_LONG + + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_LONG + ifnoerr (bp = (fwritep (fd, offset, nchars) - 1) / SZ_LONG + 1) + return (bp) + } + + vs[1] = 1 + ve[1] = IM_LEN(im,1) + vs[2] = linenum + ve[2] = linenum + + return (impgsl (im, vs, ve, 2)) + } +end diff --git a/sys/imio/tf/impl2r.x b/sys/imio/tf/impl2r.x new file mode 100644 index 00000000..43e84370 --- /dev/null +++ b/sys/imio/tf/impl2r.x @@ -0,0 +1,47 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include <imio.h> + +# IMPL2? -- Put a line to an apparently two dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure impl2r (im, linenum) + +pointer im # image header pointer +int linenum # line to be written + +int fd, nchars +long vs[2], ve[2], offset +pointer bp, impgsr(), fwritep() +errchk imopsf, imerr + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_REAL) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + if (linenum < 1 || linenum > IM_LEN(im,2)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + offset = (linenum - 1) * IM_PHYSLEN(im,1) * SZ_REAL + + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_REAL + ifnoerr (bp = (fwritep (fd, offset, nchars) - 1) / SZ_REAL + 1) + return (bp) + } + + vs[1] = 1 + ve[1] = IM_LEN(im,1) + vs[2] = linenum + ve[2] = linenum + + return (impgsr (im, vs, ve, 2)) + } +end diff --git a/sys/imio/tf/impl2s.x b/sys/imio/tf/impl2s.x new file mode 100644 index 00000000..41bc248f --- /dev/null +++ b/sys/imio/tf/impl2s.x @@ -0,0 +1,47 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include <imio.h> + +# IMPL2? -- Put a line to an apparently two dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure impl2s (im, linenum) + +pointer im # image header pointer +int linenum # line to be written + +int fd, nchars +long vs[2], ve[2], offset +pointer bp, impgss(), fwritep() +errchk imopsf, imerr + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_SHORT) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + if (linenum < 1 || linenum > IM_LEN(im,2)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + offset = (linenum - 1) * IM_PHYSLEN(im,1) * SZ_SHORT + + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_SHORT + ifnoerr (bp = (fwritep (fd, offset, nchars) - 1) / SZ_SHORT + 1) + return (bp) + } + + vs[1] = 1 + ve[1] = IM_LEN(im,1) + vs[2] = linenum + ve[2] = linenum + + return (impgss (im, vs, ve, 2)) + } +end diff --git a/sys/imio/tf/impl2x.x b/sys/imio/tf/impl2x.x new file mode 100644 index 00000000..f16e9725 --- /dev/null +++ b/sys/imio/tf/impl2x.x @@ -0,0 +1,47 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include <imio.h> + +# IMPL2? -- Put a line to an apparently two dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure impl2x (im, linenum) + +pointer im # image header pointer +int linenum # line to be written + +int fd, nchars +long vs[2], ve[2], offset +pointer bp, impgsx(), fwritep() +errchk imopsf, imerr + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_COMPLEX) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + if (linenum < 1 || linenum > IM_LEN(im,2)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + offset = (linenum - 1) * IM_PHYSLEN(im,1) * SZ_COMPLEX + + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_COMPLEX + ifnoerr (bp = (fwritep (fd, offset, nchars) - 1) / SZ_COMPLEX + 1) + return (bp) + } + + vs[1] = 1 + ve[1] = IM_LEN(im,1) + vs[2] = linenum + ve[2] = linenum + + return (impgsx (im, vs, ve, 2)) + } +end diff --git a/sys/imio/tf/impl3d.x b/sys/imio/tf/impl3d.x new file mode 100644 index 00000000..405ef94e --- /dev/null +++ b/sys/imio/tf/impl3d.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include <imio.h> + +# IMPL3? -- Put a line to an apparently three dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure impl3d (im, line, band) + +pointer im # image header pointer +int line # line number within band +int band # band number + +int fd, nchars +long vs[3], ve[3], offset +pointer bp, impgsd(), fwritep() +errchk imopsf, imerr + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_DOUBLE) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + if (line < 1 || line > IM_LEN(im,2) || + band < 1 || band > IM_LEN(im,3)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + offset = (((band - 1) * IM_PHYSLEN(im,2) + line - 1) * + IM_PHYSLEN(im,1)) * SZ_DOUBLE + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_DOUBLE + ifnoerr (bp = (fwritep (fd, offset, nchars) - 1) / SZ_DOUBLE + 1) + return (bp) + } + + vs[1] = 1 + ve[1] = IM_LEN(im,1) + vs[2] = line + ve[2] = line + vs[3] = band + ve[3] = band + + return (impgsd (im, vs, ve, 3)) + } +end diff --git a/sys/imio/tf/impl3i.x b/sys/imio/tf/impl3i.x new file mode 100644 index 00000000..0e0d4cd1 --- /dev/null +++ b/sys/imio/tf/impl3i.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include <imio.h> + +# IMPL3? -- Put a line to an apparently three dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure impl3i (im, line, band) + +pointer im # image header pointer +int line # line number within band +int band # band number + +int fd, nchars +long vs[3], ve[3], offset +pointer bp, impgsi(), fwritep() +errchk imopsf, imerr + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_INT) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + if (line < 1 || line > IM_LEN(im,2) || + band < 1 || band > IM_LEN(im,3)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + offset = (((band - 1) * IM_PHYSLEN(im,2) + line - 1) * + IM_PHYSLEN(im,1)) * SZ_INT + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_INT + ifnoerr (bp = (fwritep (fd, offset, nchars) - 1) / SZ_INT + 1) + return (bp) + } + + vs[1] = 1 + ve[1] = IM_LEN(im,1) + vs[2] = line + ve[2] = line + vs[3] = band + ve[3] = band + + return (impgsi (im, vs, ve, 3)) + } +end diff --git a/sys/imio/tf/impl3l.x b/sys/imio/tf/impl3l.x new file mode 100644 index 00000000..2471825a --- /dev/null +++ b/sys/imio/tf/impl3l.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include <imio.h> + +# IMPL3? -- Put a line to an apparently three dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure impl3l (im, line, band) + +pointer im # image header pointer +int line # line number within band +int band # band number + +int fd, nchars +long vs[3], ve[3], offset +pointer bp, impgsl(), fwritep() +errchk imopsf, imerr + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_LONG) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + if (line < 1 || line > IM_LEN(im,2) || + band < 1 || band > IM_LEN(im,3)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + offset = (((band - 1) * IM_PHYSLEN(im,2) + line - 1) * + IM_PHYSLEN(im,1)) * SZ_LONG + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_LONG + ifnoerr (bp = (fwritep (fd, offset, nchars) - 1) / SZ_LONG + 1) + return (bp) + } + + vs[1] = 1 + ve[1] = IM_LEN(im,1) + vs[2] = line + ve[2] = line + vs[3] = band + ve[3] = band + + return (impgsl (im, vs, ve, 3)) + } +end diff --git a/sys/imio/tf/impl3r.x b/sys/imio/tf/impl3r.x new file mode 100644 index 00000000..675fd8d0 --- /dev/null +++ b/sys/imio/tf/impl3r.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include <imio.h> + +# IMPL3? -- Put a line to an apparently three dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure impl3r (im, line, band) + +pointer im # image header pointer +int line # line number within band +int band # band number + +int fd, nchars +long vs[3], ve[3], offset +pointer bp, impgsr(), fwritep() +errchk imopsf, imerr + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_REAL) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + if (line < 1 || line > IM_LEN(im,2) || + band < 1 || band > IM_LEN(im,3)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + offset = (((band - 1) * IM_PHYSLEN(im,2) + line - 1) * + IM_PHYSLEN(im,1)) * SZ_REAL + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_REAL + ifnoerr (bp = (fwritep (fd, offset, nchars) - 1) / SZ_REAL + 1) + return (bp) + } + + vs[1] = 1 + ve[1] = IM_LEN(im,1) + vs[2] = line + ve[2] = line + vs[3] = band + ve[3] = band + + return (impgsr (im, vs, ve, 3)) + } +end diff --git a/sys/imio/tf/impl3s.x b/sys/imio/tf/impl3s.x new file mode 100644 index 00000000..63da06e2 --- /dev/null +++ b/sys/imio/tf/impl3s.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include <imio.h> + +# IMPL3? -- Put a line to an apparently three dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure impl3s (im, line, band) + +pointer im # image header pointer +int line # line number within band +int band # band number + +int fd, nchars +long vs[3], ve[3], offset +pointer bp, impgss(), fwritep() +errchk imopsf, imerr + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_SHORT) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + if (line < 1 || line > IM_LEN(im,2) || + band < 1 || band > IM_LEN(im,3)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + offset = (((band - 1) * IM_PHYSLEN(im,2) + line - 1) * + IM_PHYSLEN(im,1)) * SZ_SHORT + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_SHORT + ifnoerr (bp = (fwritep (fd, offset, nchars) - 1) / SZ_SHORT + 1) + return (bp) + } + + vs[1] = 1 + ve[1] = IM_LEN(im,1) + vs[2] = line + ve[2] = line + vs[3] = band + ve[3] = band + + return (impgss (im, vs, ve, 3)) + } +end diff --git a/sys/imio/tf/impl3x.x b/sys/imio/tf/impl3x.x new file mode 100644 index 00000000..85b061cd --- /dev/null +++ b/sys/imio/tf/impl3x.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <imhdr.h> +include <imio.h> + +# IMPL3? -- Put a line to an apparently three dimensional image. If there +# is only one input buffer, no image section, we are not referencing out of +# bounds, and no datatype conversion needs to be performed, directly access +# the pixels to reduce the overhead per line. + +pointer procedure impl3x (im, line, band) + +pointer im # image header pointer +int line # line number within band +int band # band number + +int fd, nchars +long vs[3], ve[3], offset +pointer bp, impgsx(), fwritep() +errchk imopsf, imerr + +begin + repeat { + if (IM_FAST(im) == YES && IM_PIXTYPE(im) == TY_COMPLEX) { + fd = IM_PFD(im) + if (fd == NULL) { + call imopsf (im) + next + } + if (line < 1 || line > IM_LEN(im,2) || + band < 1 || band > IM_LEN(im,3)) + call imerr (IM_NAME(im), SYS_IMREFOOB) + + offset = (((band - 1) * IM_PHYSLEN(im,2) + line - 1) * + IM_PHYSLEN(im,1)) * SZ_COMPLEX + IM_PIXOFF(im) + nchars = IM_PHYSLEN(im,1) * SZ_COMPLEX + ifnoerr (bp = (fwritep (fd, offset, nchars) - 1) / SZ_COMPLEX + 1) + return (bp) + } + + vs[1] = 1 + ve[1] = IM_LEN(im,1) + vs[2] = line + ve[2] = line + vs[3] = band + ve[3] = band + + return (impgsx (im, vs, ve, 3)) + } +end diff --git a/sys/imio/tf/impnld.x b/sys/imio/tf/impnld.x new file mode 100644 index 00000000..b0f9bfd5 --- /dev/null +++ b/sys/imio/tf/impnld.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> + +# IMPNL -- Put the next line to an image of any dimension or datatype. +# This is a sequential operator. The index vector V should be initialized +# before the first call to the first line to be written. Each call increments +# the leftmost subscript by one, until V equals IM_LEN, at which time EOF +# is returned. Subsequent writes are ignored. + +int procedure impnld (imdes, lineptr, v) + +pointer imdes +pointer lineptr # on output, points to the pixels +long v[IM_MAXDIM] # loop counter +int npix +int impnln() +extern imflsd() +errchk impnln + +begin + if (IM_FLUSH(imdes) == YES) + call zcall1 (IM_FLUSHEPA(imdes), imdes) + + npix = impnln (imdes, lineptr, v, TY_DOUBLE) + if (IM_FLUSH(imdes) == YES) + call zlocpr (imflsd, IM_FLUSHEPA(imdes)) + + return (npix) +end diff --git a/sys/imio/tf/impnli.x b/sys/imio/tf/impnli.x new file mode 100644 index 00000000..6155a6b6 --- /dev/null +++ b/sys/imio/tf/impnli.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> + +# IMPNL -- Put the next line to an image of any dimension or datatype. +# This is a sequential operator. The index vector V should be initialized +# before the first call to the first line to be written. Each call increments +# the leftmost subscript by one, until V equals IM_LEN, at which time EOF +# is returned. Subsequent writes are ignored. + +int procedure impnli (imdes, lineptr, v) + +pointer imdes +pointer lineptr # on output, points to the pixels +long v[IM_MAXDIM] # loop counter +int npix +int impnln() +extern imflsi() +errchk impnln + +begin + if (IM_FLUSH(imdes) == YES) + call zcall1 (IM_FLUSHEPA(imdes), imdes) + + npix = impnln (imdes, lineptr, v, TY_INT) + if (IM_FLUSH(imdes) == YES) + call zlocpr (imflsi, IM_FLUSHEPA(imdes)) + + return (npix) +end diff --git a/sys/imio/tf/impnll.x b/sys/imio/tf/impnll.x new file mode 100644 index 00000000..3fb29144 --- /dev/null +++ b/sys/imio/tf/impnll.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> + +# IMPNL -- Put the next line to an image of any dimension or datatype. +# This is a sequential operator. The index vector V should be initialized +# before the first call to the first line to be written. Each call increments +# the leftmost subscript by one, until V equals IM_LEN, at which time EOF +# is returned. Subsequent writes are ignored. + +int procedure impnll (imdes, lineptr, v) + +pointer imdes +pointer lineptr # on output, points to the pixels +long v[IM_MAXDIM] # loop counter +int npix +int impnln() +extern imflsl() +errchk impnln + +begin + if (IM_FLUSH(imdes) == YES) + call zcall1 (IM_FLUSHEPA(imdes), imdes) + + npix = impnln (imdes, lineptr, v, TY_LONG) + if (IM_FLUSH(imdes) == YES) + call zlocpr (imflsl, IM_FLUSHEPA(imdes)) + + return (npix) +end diff --git a/sys/imio/tf/impnlr.x b/sys/imio/tf/impnlr.x new file mode 100644 index 00000000..c60c8631 --- /dev/null +++ b/sys/imio/tf/impnlr.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> + +# IMPNL -- Put the next line to an image of any dimension or datatype. +# This is a sequential operator. The index vector V should be initialized +# before the first call to the first line to be written. Each call increments +# the leftmost subscript by one, until V equals IM_LEN, at which time EOF +# is returned. Subsequent writes are ignored. + +int procedure impnlr (imdes, lineptr, v) + +pointer imdes +pointer lineptr # on output, points to the pixels +long v[IM_MAXDIM] # loop counter +int npix +int impnln() +extern imflsr() +errchk impnln + +begin + if (IM_FLUSH(imdes) == YES) + call zcall1 (IM_FLUSHEPA(imdes), imdes) + + npix = impnln (imdes, lineptr, v, TY_REAL) + if (IM_FLUSH(imdes) == YES) + call zlocpr (imflsr, IM_FLUSHEPA(imdes)) + + return (npix) +end diff --git a/sys/imio/tf/impnls.x b/sys/imio/tf/impnls.x new file mode 100644 index 00000000..af85bf8a --- /dev/null +++ b/sys/imio/tf/impnls.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> + +# IMPNL -- Put the next line to an image of any dimension or datatype. +# This is a sequential operator. The index vector V should be initialized +# before the first call to the first line to be written. Each call increments +# the leftmost subscript by one, until V equals IM_LEN, at which time EOF +# is returned. Subsequent writes are ignored. + +int procedure impnls (imdes, lineptr, v) + +pointer imdes +pointer lineptr # on output, points to the pixels +long v[IM_MAXDIM] # loop counter +int npix +int impnln() +extern imflss() +errchk impnln + +begin + if (IM_FLUSH(imdes) == YES) + call zcall1 (IM_FLUSHEPA(imdes), imdes) + + npix = impnln (imdes, lineptr, v, TY_SHORT) + if (IM_FLUSH(imdes) == YES) + call zlocpr (imflss, IM_FLUSHEPA(imdes)) + + return (npix) +end diff --git a/sys/imio/tf/impnlx.x b/sys/imio/tf/impnlx.x new file mode 100644 index 00000000..e76cf1f1 --- /dev/null +++ b/sys/imio/tf/impnlx.x @@ -0,0 +1,31 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> + +# IMPNL -- Put the next line to an image of any dimension or datatype. +# This is a sequential operator. The index vector V should be initialized +# before the first call to the first line to be written. Each call increments +# the leftmost subscript by one, until V equals IM_LEN, at which time EOF +# is returned. Subsequent writes are ignored. + +int procedure impnlx (imdes, lineptr, v) + +pointer imdes +pointer lineptr # on output, points to the pixels +long v[IM_MAXDIM] # loop counter +int npix +int impnln() +extern imflsx() +errchk impnln + +begin + if (IM_FLUSH(imdes) == YES) + call zcall1 (IM_FLUSHEPA(imdes), imdes) + + npix = impnln (imdes, lineptr, v, TY_COMPLEX) + if (IM_FLUSH(imdes) == YES) + call zlocpr (imflsx, IM_FLUSHEPA(imdes)) + + return (npix) +end diff --git a/sys/imio/tf/imps1d.x b/sys/imio/tf/imps1d.x new file mode 100644 index 00000000..c8dd82b1 --- /dev/null +++ b/sys/imio/tf/imps1d.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMPS1? -- Put a section to an apparently one dimensional image. + +pointer procedure imps1d (im, x1, x2) + +pointer im # image header pointer +int x1 # first column +int x2 # last column + +pointer impgsd(), impl1d() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1)) + return (impl1d (im)) + else + return (impgsd (im, long(x1), long(x2), 1)) +end diff --git a/sys/imio/tf/imps1i.x b/sys/imio/tf/imps1i.x new file mode 100644 index 00000000..cb97a374 --- /dev/null +++ b/sys/imio/tf/imps1i.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMPS1? -- Put a section to an apparently one dimensional image. + +pointer procedure imps1i (im, x1, x2) + +pointer im # image header pointer +int x1 # first column +int x2 # last column + +pointer impgsi(), impl1i() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1)) + return (impl1i (im)) + else + return (impgsi (im, long(x1), long(x2), 1)) +end diff --git a/sys/imio/tf/imps1l.x b/sys/imio/tf/imps1l.x new file mode 100644 index 00000000..c8f5aae4 --- /dev/null +++ b/sys/imio/tf/imps1l.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMPS1? -- Put a section to an apparently one dimensional image. + +pointer procedure imps1l (im, x1, x2) + +pointer im # image header pointer +int x1 # first column +int x2 # last column + +pointer impgsl(), impl1l() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1)) + return (impl1l (im)) + else + return (impgsl (im, long(x1), long(x2), 1)) +end diff --git a/sys/imio/tf/imps1r.x b/sys/imio/tf/imps1r.x new file mode 100644 index 00000000..1bd1434c --- /dev/null +++ b/sys/imio/tf/imps1r.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMPS1? -- Put a section to an apparently one dimensional image. + +pointer procedure imps1r (im, x1, x2) + +pointer im # image header pointer +int x1 # first column +int x2 # last column + +pointer impgsr(), impl1r() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1)) + return (impl1r (im)) + else + return (impgsr (im, long(x1), long(x2), 1)) +end diff --git a/sys/imio/tf/imps1s.x b/sys/imio/tf/imps1s.x new file mode 100644 index 00000000..130e7f18 --- /dev/null +++ b/sys/imio/tf/imps1s.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMPS1? -- Put a section to an apparently one dimensional image. + +pointer procedure imps1s (im, x1, x2) + +pointer im # image header pointer +int x1 # first column +int x2 # last column + +pointer impgss(), impl1s() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1)) + return (impl1s (im)) + else + return (impgss (im, long(x1), long(x2), 1)) +end diff --git a/sys/imio/tf/imps1x.x b/sys/imio/tf/imps1x.x new file mode 100644 index 00000000..5a5c33a0 --- /dev/null +++ b/sys/imio/tf/imps1x.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMPS1? -- Put a section to an apparently one dimensional image. + +pointer procedure imps1x (im, x1, x2) + +pointer im # image header pointer +int x1 # first column +int x2 # last column + +pointer impgsx(), impl1x() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1)) + return (impl1x (im)) + else + return (impgsx (im, long(x1), long(x2), 1)) +end diff --git a/sys/imio/tf/imps2d.x b/sys/imio/tf/imps2d.x new file mode 100644 index 00000000..e3f36fd9 --- /dev/null +++ b/sys/imio/tf/imps2d.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMPS2? -- Put a section to an apparently two dimensional image. + +pointer procedure imps2d (im, x1, x2, y1, y2) + +pointer im +int x1, x2, y1, y2 +long vs[2], ve[2] +pointer impgsd(), impl2d() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1) && y1 == y2) + return (impl2d (im, y1)) + else { + vs[1] = x1 + ve[1] = x2 + + vs[2] = y1 + ve[2] = y2 + + return (impgsd (im, vs, ve, 2)) + } +end diff --git a/sys/imio/tf/imps2i.x b/sys/imio/tf/imps2i.x new file mode 100644 index 00000000..57e3f36c --- /dev/null +++ b/sys/imio/tf/imps2i.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMPS2? -- Put a section to an apparently two dimensional image. + +pointer procedure imps2i (im, x1, x2, y1, y2) + +pointer im +int x1, x2, y1, y2 +long vs[2], ve[2] +pointer impgsi(), impl2i() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1) && y1 == y2) + return (impl2i (im, y1)) + else { + vs[1] = x1 + ve[1] = x2 + + vs[2] = y1 + ve[2] = y2 + + return (impgsi (im, vs, ve, 2)) + } +end diff --git a/sys/imio/tf/imps2l.x b/sys/imio/tf/imps2l.x new file mode 100644 index 00000000..2d7bc8b7 --- /dev/null +++ b/sys/imio/tf/imps2l.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMPS2? -- Put a section to an apparently two dimensional image. + +pointer procedure imps2l (im, x1, x2, y1, y2) + +pointer im +int x1, x2, y1, y2 +long vs[2], ve[2] +pointer impgsl(), impl2l() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1) && y1 == y2) + return (impl2l (im, y1)) + else { + vs[1] = x1 + ve[1] = x2 + + vs[2] = y1 + ve[2] = y2 + + return (impgsl (im, vs, ve, 2)) + } +end diff --git a/sys/imio/tf/imps2r.x b/sys/imio/tf/imps2r.x new file mode 100644 index 00000000..ce8b2958 --- /dev/null +++ b/sys/imio/tf/imps2r.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMPS2? -- Put a section to an apparently two dimensional image. + +pointer procedure imps2r (im, x1, x2, y1, y2) + +pointer im +int x1, x2, y1, y2 +long vs[2], ve[2] +pointer impgsr(), impl2r() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1) && y1 == y2) + return (impl2r (im, y1)) + else { + vs[1] = x1 + ve[1] = x2 + + vs[2] = y1 + ve[2] = y2 + + return (impgsr (im, vs, ve, 2)) + } +end diff --git a/sys/imio/tf/imps2s.x b/sys/imio/tf/imps2s.x new file mode 100644 index 00000000..c5993a61 --- /dev/null +++ b/sys/imio/tf/imps2s.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMPS2? -- Put a section to an apparently two dimensional image. + +pointer procedure imps2s (im, x1, x2, y1, y2) + +pointer im +int x1, x2, y1, y2 +long vs[2], ve[2] +pointer impgss(), impl2s() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1) && y1 == y2) + return (impl2s (im, y1)) + else { + vs[1] = x1 + ve[1] = x2 + + vs[2] = y1 + ve[2] = y2 + + return (impgss (im, vs, ve, 2)) + } +end diff --git a/sys/imio/tf/imps2x.x b/sys/imio/tf/imps2x.x new file mode 100644 index 00000000..12db84a5 --- /dev/null +++ b/sys/imio/tf/imps2x.x @@ -0,0 +1,26 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMPS2? -- Put a section to an apparently two dimensional image. + +pointer procedure imps2x (im, x1, x2, y1, y2) + +pointer im +int x1, x2, y1, y2 +long vs[2], ve[2] +pointer impgsx(), impl2x() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1) && y1 == y2) + return (impl2x (im, y1)) + else { + vs[1] = x1 + ve[1] = x2 + + vs[2] = y1 + ve[2] = y2 + + return (impgsx (im, vs, ve, 2)) + } +end diff --git a/sys/imio/tf/imps3d.x b/sys/imio/tf/imps3d.x new file mode 100644 index 00000000..0cd67b5e --- /dev/null +++ b/sys/imio/tf/imps3d.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMPS3? -- Put a section to an apparently three dimensional image. + +pointer procedure imps3d (im, x1, x2, y1, y2, z1, z2) + +pointer im +int x1, x2, y1, y2, z1, z2 +long vs[3], ve[3] +pointer impgsd(), impl3d() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1) && y1 == y2 && z1 == z2) + return (impl3d (im, y1, z1)) + else { + vs[1] = x1 + ve[1] = x2 + + vs[2] = y1 + ve[2] = y2 + + vs[3] = z1 + ve[3] = z2 + + return (impgsd (im, vs, ve, 3)) + } +end diff --git a/sys/imio/tf/imps3i.x b/sys/imio/tf/imps3i.x new file mode 100644 index 00000000..9ec4a832 --- /dev/null +++ b/sys/imio/tf/imps3i.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMPS3? -- Put a section to an apparently three dimensional image. + +pointer procedure imps3i (im, x1, x2, y1, y2, z1, z2) + +pointer im +int x1, x2, y1, y2, z1, z2 +long vs[3], ve[3] +pointer impgsi(), impl3i() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1) && y1 == y2 && z1 == z2) + return (impl3i (im, y1, z1)) + else { + vs[1] = x1 + ve[1] = x2 + + vs[2] = y1 + ve[2] = y2 + + vs[3] = z1 + ve[3] = z2 + + return (impgsi (im, vs, ve, 3)) + } +end diff --git a/sys/imio/tf/imps3l.x b/sys/imio/tf/imps3l.x new file mode 100644 index 00000000..a68b2de5 --- /dev/null +++ b/sys/imio/tf/imps3l.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMPS3? -- Put a section to an apparently three dimensional image. + +pointer procedure imps3l (im, x1, x2, y1, y2, z1, z2) + +pointer im +int x1, x2, y1, y2, z1, z2 +long vs[3], ve[3] +pointer impgsl(), impl3l() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1) && y1 == y2 && z1 == z2) + return (impl3l (im, y1, z1)) + else { + vs[1] = x1 + ve[1] = x2 + + vs[2] = y1 + ve[2] = y2 + + vs[3] = z1 + ve[3] = z2 + + return (impgsl (im, vs, ve, 3)) + } +end diff --git a/sys/imio/tf/imps3r.x b/sys/imio/tf/imps3r.x new file mode 100644 index 00000000..4fcbecff --- /dev/null +++ b/sys/imio/tf/imps3r.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMPS3? -- Put a section to an apparently three dimensional image. + +pointer procedure imps3r (im, x1, x2, y1, y2, z1, z2) + +pointer im +int x1, x2, y1, y2, z1, z2 +long vs[3], ve[3] +pointer impgsr(), impl3r() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1) && y1 == y2 && z1 == z2) + return (impl3r (im, y1, z1)) + else { + vs[1] = x1 + ve[1] = x2 + + vs[2] = y1 + ve[2] = y2 + + vs[3] = z1 + ve[3] = z2 + + return (impgsr (im, vs, ve, 3)) + } +end diff --git a/sys/imio/tf/imps3s.x b/sys/imio/tf/imps3s.x new file mode 100644 index 00000000..3758b3b9 --- /dev/null +++ b/sys/imio/tf/imps3s.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMPS3? -- Put a section to an apparently three dimensional image. + +pointer procedure imps3s (im, x1, x2, y1, y2, z1, z2) + +pointer im +int x1, x2, y1, y2, z1, z2 +long vs[3], ve[3] +pointer impgss(), impl3s() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1) && y1 == y2 && z1 == z2) + return (impl3s (im, y1, z1)) + else { + vs[1] = x1 + ve[1] = x2 + + vs[2] = y1 + ve[2] = y2 + + vs[3] = z1 + ve[3] = z2 + + return (impgss (im, vs, ve, 3)) + } +end diff --git a/sys/imio/tf/imps3x.x b/sys/imio/tf/imps3x.x new file mode 100644 index 00000000..7062a3c1 --- /dev/null +++ b/sys/imio/tf/imps3x.x @@ -0,0 +1,29 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> + +# IMPS3? -- Put a section to an apparently three dimensional image. + +pointer procedure imps3x (im, x1, x2, y1, y2, z1, z2) + +pointer im +int x1, x2, y1, y2, z1, z2 +long vs[3], ve[3] +pointer impgsx(), impl3x() + +begin + if (x1 == 1 && x2 == IM_LEN(im,1) && y1 == y2 && z1 == z2) + return (impl3x (im, y1, z1)) + else { + vs[1] = x1 + ve[1] = x2 + + vs[2] = y1 + ve[2] = y2 + + vs[3] = z1 + ve[3] = z2 + + return (impgsx (im, vs, ve, 3)) + } +end diff --git a/sys/imio/tf/imupkd.x b/sys/imio/tf/imupkd.x new file mode 100644 index 00000000..ffbbe81e --- /dev/null +++ b/sys/imio/tf/imupkd.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMUPK? -- Convert an array of pixels of datatype DTYPE into the datatype +# specified by the IMUPK? suffix character. + +procedure imupkd (a, b, npix, dtype) + +double b[npix] +int a[npix], npix, dtype + +pointer bp + +begin + switch (dtype) { + case TY_USHORT: + call achtud (a, b, npix) + case TY_SHORT: + call achtsd (a, b, npix) + case TY_INT: + call achtid (a, b, npix) + case TY_LONG: + call achtld (a, b, npix) + case TY_REAL: + call achtrd (a, b, npix) + case TY_DOUBLE: + call achtdd (a, b, npix) + case TY_COMPLEX: + call achtxd (a, b, npix) + default: + call error (1, "Unknown datatype in imagefile") + } +end + + diff --git a/sys/imio/tf/imupki.x b/sys/imio/tf/imupki.x new file mode 100644 index 00000000..0703b22b --- /dev/null +++ b/sys/imio/tf/imupki.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMUPK? -- Convert an array of pixels of datatype DTYPE into the datatype +# specified by the IMUPK? suffix character. + +procedure imupki (a, b, npix, dtype) + +int b[npix] +int a[npix], npix, dtype + +pointer bp + +begin + switch (dtype) { + case TY_USHORT: + call achtui (a, b, npix) + case TY_SHORT: + call achtsi (a, b, npix) + case TY_INT: + call achtii (a, b, npix) + case TY_LONG: + call achtli (a, b, npix) + case TY_REAL: + call achtri (a, b, npix) + case TY_DOUBLE: + call achtdi (a, b, npix) + case TY_COMPLEX: + call achtxi (a, b, npix) + default: + call error (1, "Unknown datatype in imagefile") + } +end + + diff --git a/sys/imio/tf/imupkl.x b/sys/imio/tf/imupkl.x new file mode 100644 index 00000000..1b144e29 --- /dev/null +++ b/sys/imio/tf/imupkl.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMUPK? -- Convert an array of pixels of datatype DTYPE into the datatype +# specified by the IMUPK? suffix character. + +procedure imupkl (a, b, npix, dtype) + +long b[npix] +int a[npix], npix, dtype + +pointer bp + +begin + switch (dtype) { + case TY_USHORT: + call achtul (a, b, npix) + case TY_SHORT: + call achtsl (a, b, npix) + case TY_INT: + call achtil (a, b, npix) + case TY_LONG: + call achtll (a, b, npix) + case TY_REAL: + call achtrl (a, b, npix) + case TY_DOUBLE: + call achtdl (a, b, npix) + case TY_COMPLEX: + call achtxl (a, b, npix) + default: + call error (1, "Unknown datatype in imagefile") + } +end + + diff --git a/sys/imio/tf/imupkr.x b/sys/imio/tf/imupkr.x new file mode 100644 index 00000000..0cfccefc --- /dev/null +++ b/sys/imio/tf/imupkr.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMUPK? -- Convert an array of pixels of datatype DTYPE into the datatype +# specified by the IMUPK? suffix character. + +procedure imupkr (a, b, npix, dtype) + +real b[npix] +int a[npix], npix, dtype + +pointer bp + +begin + switch (dtype) { + case TY_USHORT: + call achtur (a, b, npix) + case TY_SHORT: + call achtsr (a, b, npix) + case TY_INT: + call achtir (a, b, npix) + case TY_LONG: + call achtlr (a, b, npix) + case TY_REAL: + call achtrr (a, b, npix) + case TY_DOUBLE: + call achtdr (a, b, npix) + case TY_COMPLEX: + call achtxr (a, b, npix) + default: + call error (1, "Unknown datatype in imagefile") + } +end + + diff --git a/sys/imio/tf/imupks.x b/sys/imio/tf/imupks.x new file mode 100644 index 00000000..93d0ad3f --- /dev/null +++ b/sys/imio/tf/imupks.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMUPK? -- Convert an array of pixels of datatype DTYPE into the datatype +# specified by the IMUPK? suffix character. + +procedure imupks (a, b, npix, dtype) + +short b[npix] +int a[npix], npix, dtype + +pointer bp + +begin + switch (dtype) { + case TY_USHORT: + call achtus (a, b, npix) + case TY_SHORT: + call achtss (a, b, npix) + case TY_INT: + call achtis (a, b, npix) + case TY_LONG: + call achtls (a, b, npix) + case TY_REAL: + call achtrs (a, b, npix) + case TY_DOUBLE: + call achtds (a, b, npix) + case TY_COMPLEX: + call achtxs (a, b, npix) + default: + call error (1, "Unknown datatype in imagefile") + } +end + + diff --git a/sys/imio/tf/imupkx.x b/sys/imio/tf/imupkx.x new file mode 100644 index 00000000..916bb73b --- /dev/null +++ b/sys/imio/tf/imupkx.x @@ -0,0 +1,34 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMUPK? -- Convert an array of pixels of datatype DTYPE into the datatype +# specified by the IMUPK? suffix character. + +procedure imupkx (a, b, npix, dtype) + +complex b[npix] +int a[npix], npix, dtype + +pointer bp + +begin + switch (dtype) { + case TY_USHORT: + call achtux (a, b, npix) + case TY_SHORT: + call achtsx (a, b, npix) + case TY_INT: + call achtix (a, b, npix) + case TY_LONG: + call achtlx (a, b, npix) + case TY_REAL: + call achtrx (a, b, npix) + case TY_DOUBLE: + call achtdx (a, b, npix) + case TY_COMPLEX: + call achtxx (a, b, npix) + default: + call error (1, "Unknown datatype in imagefile") + } +end + + diff --git a/sys/imio/tf/mkpkg b/sys/imio/tf/mkpkg new file mode 100644 index 00000000..a79ca832 --- /dev/null +++ b/sys/imio/tf/mkpkg @@ -0,0 +1,123 @@ +# Update the type specific (generically expanded) IMIO procedures. + +$checkout libex.a lib$ +$update libex.a +$checkin libex.a lib$ +$exit + +libex.a: + imflsd.x <imhdr.h> <imio.h> + imflsi.x <imhdr.h> <imio.h> + imflsl.x <imhdr.h> <imio.h> + imflsr.x <imhdr.h> <imio.h> + imflss.x <imhdr.h> <imio.h> + imflsx.x <imhdr.h> <imio.h> + imggsd.x <imhdr.h> + imggsi.x <imhdr.h> + imggsl.x <imhdr.h> + imggsr.x <imhdr.h> + imggss.x <imhdr.h> + imggsx.x <imhdr.h> + imgl1d.x <imhdr.h> <imio.h> + imgl1i.x <imhdr.h> <imio.h> + imgl1l.x <imhdr.h> <imio.h> + imgl1r.x <imhdr.h> <imio.h> + imgl1s.x <imhdr.h> <imio.h> + imgl1x.x <imhdr.h> <imio.h> + imgl2d.x <imhdr.h> <imio.h> + imgl2i.x <imhdr.h> <imio.h> + imgl2l.x <imhdr.h> <imio.h> + imgl2r.x <imhdr.h> <imio.h> + imgl2s.x <imhdr.h> <imio.h> + imgl2x.x <imhdr.h> <imio.h> + imgl3d.x <imhdr.h> <imio.h> + imgl3i.x <imhdr.h> <imio.h> + imgl3l.x <imhdr.h> <imio.h> + imgl3r.x <imhdr.h> <imio.h> + imgl3s.x <imhdr.h> <imio.h> + imgl3x.x <imhdr.h> <imio.h> + imgnld.x <imhdr.h> + imgnli.x <imhdr.h> + imgnll.x <imhdr.h> + imgnlr.x <imhdr.h> + imgnls.x <imhdr.h> + imgnlx.x <imhdr.h> + imgs1d.x <imhdr.h> + imgs1i.x <imhdr.h> + imgs1l.x <imhdr.h> + imgs1r.x <imhdr.h> + imgs1s.x <imhdr.h> + imgs1x.x <imhdr.h> + imgs2d.x <imhdr.h> + imgs2i.x <imhdr.h> + imgs2l.x <imhdr.h> + imgs2r.x <imhdr.h> + imgs2s.x <imhdr.h> + imgs2x.x <imhdr.h> + imgs3d.x <imhdr.h> + imgs3i.x <imhdr.h> + imgs3l.x <imhdr.h> + imgs3r.x <imhdr.h> + imgs3s.x <imhdr.h> + imgs3x.x <imhdr.h> + impakd.x + impaki.x + impakl.x + impakr.x + impaks.x + impakx.x + impgsd.x <imhdr.h> <imio.h> + impgsi.x <imhdr.h> <imio.h> + impgsl.x <imhdr.h> <imio.h> + impgsr.x <imhdr.h> <imio.h> + impgss.x <imhdr.h> <imio.h> + impgsx.x <imhdr.h> <imio.h> + impl1d.x <imhdr.h> <imio.h> + impl1i.x <imhdr.h> <imio.h> + impl1l.x <imhdr.h> <imio.h> + impl1r.x <imhdr.h> <imio.h> + impl1s.x <imhdr.h> <imio.h> + impl1x.x <imhdr.h> <imio.h> + impl2d.x <imhdr.h> <imio.h> + impl2i.x <imhdr.h> <imio.h> + impl2l.x <imhdr.h> <imio.h> + impl2r.x <imhdr.h> <imio.h> + impl2s.x <imhdr.h> <imio.h> + impl2x.x <imhdr.h> <imio.h> + impl3d.x <imhdr.h> <imio.h> + impl3i.x <imhdr.h> <imio.h> + impl3l.x <imhdr.h> <imio.h> + impl3r.x <imhdr.h> <imio.h> + impl3s.x <imhdr.h> <imio.h> + impl3x.x <imhdr.h> <imio.h> + impnld.x <imhdr.h> <imio.h> + impnli.x <imhdr.h> <imio.h> + impnll.x <imhdr.h> <imio.h> + impnlr.x <imhdr.h> <imio.h> + impnls.x <imhdr.h> <imio.h> + impnlx.x <imhdr.h> <imio.h> + imps1d.x <imhdr.h> + imps1i.x <imhdr.h> + imps1l.x <imhdr.h> + imps1r.x <imhdr.h> + imps1s.x <imhdr.h> + imps1x.x <imhdr.h> + imps2d.x <imhdr.h> + imps2i.x <imhdr.h> + imps2l.x <imhdr.h> + imps2r.x <imhdr.h> + imps2s.x <imhdr.h> + imps2x.x <imhdr.h> + imps3d.x <imhdr.h> + imps3i.x <imhdr.h> + imps3l.x <imhdr.h> + imps3r.x <imhdr.h> + imps3s.x <imhdr.h> + imps3x.x <imhdr.h> + imupkd.x + imupki.x + imupkl.x + imupkr.x + imupks.x + imupkx.x + ; diff --git a/sys/imio/zzdebug.x b/sys/imio/zzdebug.x new file mode 100644 index 00000000..2772b27c --- /dev/null +++ b/sys/imio/zzdebug.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +task imt = t_imt + +# IMT -- Test the image template package. + +procedure t_imt() + +char template[SZ_LINE] +char image[SZ_FNAME] +pointer imt, imtopen() +int imtgetim() + +begin + call clgstr ("template", template, SZ_LINE) + imt = imtopen (template) + + while (imtgetim (imt, image, SZ_FNAME) != EOF) { + call printf ("%s\n") + call pargstr (image) + } + + call imtclose (imt) +end |