From 40e5a5811c6ffce9b0974e93cdd927cbcf60c157 Mon Sep 17 00:00:00 2001 From: Joe Hunkeler Date: Tue, 11 Aug 2015 16:51:37 -0400 Subject: Repatch (from linux) of OSX IRAF --- sys/imfort/db/README | 120 +++++++++++++++++ sys/imfort/db/idb.h | 22 +++ sys/imfort/db/idbfind.x | 124 +++++++++++++++++ sys/imfort/db/idbgstr.x | 78 +++++++++++ sys/imfort/db/idbkwlu.x | 52 ++++++++ sys/imfort/db/idbnaxis.x | 32 +++++ sys/imfort/db/idbpstr.x | 96 ++++++++++++++ sys/imfort/db/imaccf.x | 18 +++ sys/imfort/db/imaddb.x | 20 +++ sys/imfort/db/imaddd.x | 20 +++ sys/imfort/db/imaddf.x | 76 +++++++++++ sys/imfort/db/imaddi.x | 20 +++ sys/imfort/db/imaddl.x | 20 +++ sys/imfort/db/imaddr.x | 20 +++ sys/imfort/db/imadds.x | 20 +++ sys/imfort/db/imastr.x | 18 +++ sys/imfort/db/imdelf.x | 44 ++++++ sys/imfort/db/imgatr.x | 51 +++++++ sys/imfort/db/imgetb.x | 20 +++ sys/imfort/db/imgetc.x | 13 ++ sys/imfort/db/imgetd.x | 32 +++++ sys/imfort/db/imgeti.x | 19 +++ sys/imfort/db/imgetl.x | 19 +++ sys/imfort/db/imgetr.x | 19 +++ sys/imfort/db/imgets.x | 19 +++ sys/imfort/db/imgftype.x | 76 +++++++++++ sys/imfort/db/imgnfn.x | 338 +++++++++++++++++++++++++++++++++++++++++++++++ sys/imfort/db/imgstr.x | 41 ++++++ sys/imfort/db/impstr.x | 72 ++++++++++ sys/imfort/db/imputb.x | 20 +++ sys/imfort/db/imputd.x | 37 ++++++ sys/imfort/db/imputi.x | 18 +++ sys/imfort/db/imputl.x | 23 ++++ sys/imfort/db/imputr.x | 18 +++ sys/imfort/db/imputs.x | 18 +++ sys/imfort/db/mkpkg | 42 ++++++ 36 files changed, 1695 insertions(+) create mode 100644 sys/imfort/db/README create mode 100644 sys/imfort/db/idb.h create mode 100644 sys/imfort/db/idbfind.x create mode 100644 sys/imfort/db/idbgstr.x create mode 100644 sys/imfort/db/idbkwlu.x create mode 100644 sys/imfort/db/idbnaxis.x create mode 100644 sys/imfort/db/idbpstr.x create mode 100644 sys/imfort/db/imaccf.x create mode 100644 sys/imfort/db/imaddb.x create mode 100644 sys/imfort/db/imaddd.x create mode 100644 sys/imfort/db/imaddf.x create mode 100644 sys/imfort/db/imaddi.x create mode 100644 sys/imfort/db/imaddl.x create mode 100644 sys/imfort/db/imaddr.x create mode 100644 sys/imfort/db/imadds.x create mode 100644 sys/imfort/db/imastr.x create mode 100644 sys/imfort/db/imdelf.x create mode 100644 sys/imfort/db/imgatr.x create mode 100644 sys/imfort/db/imgetb.x create mode 100644 sys/imfort/db/imgetc.x create mode 100644 sys/imfort/db/imgetd.x create mode 100644 sys/imfort/db/imgeti.x create mode 100644 sys/imfort/db/imgetl.x create mode 100644 sys/imfort/db/imgetr.x create mode 100644 sys/imfort/db/imgets.x create mode 100644 sys/imfort/db/imgftype.x create mode 100644 sys/imfort/db/imgnfn.x create mode 100644 sys/imfort/db/imgstr.x create mode 100644 sys/imfort/db/impstr.x create mode 100644 sys/imfort/db/imputb.x create mode 100644 sys/imfort/db/imputd.x create mode 100644 sys/imfort/db/imputi.x create mode 100644 sys/imfort/db/imputl.x create mode 100644 sys/imfort/db/imputr.x create mode 100644 sys/imfort/db/imputs.x create mode 100644 sys/imfort/db/mkpkg (limited to 'sys/imfort/db') diff --git a/sys/imfort/db/README b/sys/imfort/db/README new file mode 100644 index 00000000..1503a949 --- /dev/null +++ b/sys/imfort/db/README @@ -0,0 +1,120 @@ +IMFORT/DB -- Image header keyword access for IMFORT (20Apr86) + + This directory contains a version of the imio/db package, modified for +IMFORT. The modifications consisted of [1] elimination of calls to the +various printf routines, so that only pure code (no external dependencies +or use of VOS i/o) is linked into the Fortran program, [2] deleted imgnfn +template stuff, [3] added provision for comments when adding new keywords, +[4] changed datatype code to integer uniformly. Error checking is still +used but should be iferr-ed and turned into an IER code in the Fortran +binding. + + +Old IDBI readme docs: +---------------------------------------- + + Image Header Database Interface + dct 16-Apr-85 + +1. Overview + + This directory contains the first version of the image header database +interface. In this implementation the image header is a variable length fixed +format binary structure. The first, fixed format, part of the image header +contains the standard fields in binary and is fixed in size. This is followed +by the so called "user area", a string buffer containing a sequence of +variable length, newline delimited FITS format keyword=value header cards. +When an image is open a large user area is allocated to permit the addition +of new parameters without filling up the buffer. When the header is +subsequently updated on disk only as much disk space is used as is needed to +store the actual header. + +This format header is upwards compatible with the old image header format, +hence old images and programs do not have to be modified to use the IMIO +release supporting database accesss. In the future image headers will be +maintained under DBIO, but the routines in the image header database interface +are not exected to change. The actual disk format of images will of course +change when we switch over to the DBIO headers. + + + +2. Functions + + get,g - get the value of a field + put,p - set the value of a field + add,a - add a new field to a database + acc - determine if the named field exists + + +3. Procedures + + value = imget[bcsilrdx] (im, "field") + imgstr (im, "field", outstr, maxch) + imput[bcsilrdx] (im, "field", value) + impstr (im, "field", value) + imadd[bcsilrdx] (im, "field", def_value) + imastr (im, "field", def_value) + imaddf (im, "field", "datatype") + y/n = imaccf (im, "field") + + list = imofnl[su] (im, template) + nch = imgnfn (im, outstr, maxch) + imcfnl (im) + + + +4. Description + + New parameters will typically be added to the image header with either +one of the typed procedures IMADD_ or with the lower level procedure IMADDF. +The former procedures permit the parameter to be created and the value +initialized all in one call, while the latter only creates the parameter. +In addition, the typed IMADD_ procedures may be used to update the values +of existing parameters (it is not considered an error if the parameter +already exists). The principal limitation of the typed procedures is that +they may only be used to add or set parameters of a standard datatype. +The IMADDF procedure will permit creation of parameters with more descriptive +datatypes (domains) when the interface is recut upon DBIO. + +The value of any parameter may be fetched with one of the IMGET functions. +The IMACCF function may be used (like ACCESS for a file) to determine +whether a parameter exists. + +The database interface may be used to access any field of the image header, +including the following standard fields. Note that the nomenclature has +been changed slightly to make it more consistent with FITS. Additional +standard fields will be defined in the future. + + + keyword type description + + i_naxis i number of axes (dimensionality) + i_naxis[1-7] l length of an axis ("i_naxis1", etc.) + i_pixtype i pixel datatype (SPP integer code) + i_minpixval r minimum pixel value + i_maxpixval r maximum pixel value + i_ctime l time of image creation + i_mtime l time of last modify + i_limtime l time when limits (minmax) were last updated + i_title s title string + + +The names of the standard fields share an "i_" prefix to reduce the possibility +of collisions with data dependent keywords, to identify the standard fields in +sorted listings, to allow use of pattern matching to discriminate between the +standard fields and user fields, and so on. For the convenience of the user, +the "i_" prefix may be omitted provided the resultant name does not match the +name of a user parameter. It is however recommended that the full name be +used in all applications software. + + +5. Restrictions + + The use of FITS format as the internal format for storing fields in this +version of the interface places restrictions on the size of field names and +of the string value of string valued parameters. Field names are currently +limited to eight characters or less and case is ignored (since FITS requires +upper case). The eight character limit does not apply to the standard fields. +String values are limited to at most 68 characters. If put string is passed +a longer string it will be silently truncated. Trailing whitespace and +newlines are chopped when a string value is read. diff --git a/sys/imfort/db/idb.h b/sys/imfort/db/idb.h new file mode 100644 index 00000000..a430f01f --- /dev/null +++ b/sys/imfort/db/idb.h @@ -0,0 +1,22 @@ +# IDB.H -- Image header database interface. In this version of the interface +# the standard image header fields are maintained in binary in a fixed +# structure and the user fields are maintained in FITS format (text) in the +# a string buffer following the binary image header. + +define IDB_RECLEN 80 # length of a FITS record (card) +define IDB_STARTVALUE 10 # first column of value field +define IDB_ENDVALUE 30 # last column of value field +define IDB_LENNUMERICRECORD 80 # length of new numeric records +define IDB_LENSTRINGRECORD 80 # length of new string records + +# Standard header keywords accessible via the database interface. + +define I_CTIME 1 +define I_MTIME 2 +define I_LIMTIME 3 +define I_MINPIXVAL 4 +define I_MAXPIXVAL 5 +define I_NAXIS 6 +define I_PIXFILE 7 +define I_PIXTYPE 8 +define I_TITLE 9 diff --git a/sys/imfort/db/idbfind.x b/sys/imfort/db/idbfind.x new file mode 100644 index 00000000..cc9000ec --- /dev/null +++ b/sys/imfort/db/idbfind.x @@ -0,0 +1,124 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "../imfort.h" +include "idb.h" + +# IDB_FINDRECORD -- Search the image database for a particular record given +# the key. The record number (a positive nonzero integer) is returned if +# the record is found, else 0. + +int procedure idb_findrecord (im, key, rp) + +pointer im # image descriptor +char key[ARB] # record key +pointer rp # char record pointer (output) + +pointer sp, pat, patbuf, ukey, lkey, ip, ua +int recno, nchars, lch, uch, ch, junk, i +int patmake(), patmatch(), gstrcpy() + +begin + call smark (sp) + call salloc (pat, SZ_FNAME, TY_CHAR) + call salloc (ukey, SZ_FNAME, TY_CHAR) + call salloc (lkey, SZ_FNAME, TY_CHAR) + call salloc (patbuf, SZ_LINE, TY_CHAR) + + # Search for the FIRST occurrence of a record with the given key. + # If the key is abbreviated and multiple keys are matched, the first + # record matched is used. + + ua = IM_USERAREA(im) + rp = NULL + recno = 1 + + if (IM_UABLOCKED(im) < 0) { + # At image open time this flag is set by IMMAP to -1 to indicate + # that the user area record type is not known. An IKI kernel may + # subsequently set the flag to yes/no, else we determine the + # record type by inspection the first time we are called. If the + # user area is empty the record type is set to blocked; IDB always + # writes blocked records. + + IM_UABLOCKED(im) = YES + for (ip=ua; Memc[ip] != EOS; ip=ip+1) { + for (nchars=0; Memc[ip] != EOS; nchars=nchars+1) { + if (Memc[ip] == '\n') + break + ip = ip + 1 + } + if (nchars != IDB_RECLEN) { + IM_UABLOCKED(im) = NO + break + } + } + } + + if (IM_UABLOCKED(im) == NO) { + # Variable length, newline terminated records, EOS terminated + # record group. + + call strcpy ("^{", Memc[pat], SZ_FNAME) + call strcat (key, Memc[pat], SZ_FNAME) + call strcat ("}[ =]", Memc[pat], SZ_FNAME) + junk = patmake (Memc[pat], Memc[patbuf], SZ_LINE) + + for (ip=ua; Memc[ip] != EOS; ip=ip+1) { + if (patmatch (Memc[ip], Memc[patbuf]) > 0) { + rp = ip + break + } + while (Memc[ip] != '\n' && Memc[ip] != EOS) + ip = ip + 1 + recno = recno + 1 + } + + } else { + # Fixed length (80 character), newline terminated records, EOS + # terminated record group. Simple fast search, fixed length + # records. Case insensitive keyword match. + + nchars = gstrcpy (key, Memc[lkey], SZ_FNAME) + call strlwr (Memc[lkey]) + lch = Memc[lkey] + + nchars = gstrcpy (key, Memc[ukey], SZ_FNAME) + call strupr (Memc[ukey]) + uch = Memc[ukey] + + for (ip=ua; Memc[ip] != EOS; ip=ip+IDB_RECLEN+1) { + ch = Memc[ip] + if (ch == EOS) + break + else if (ch != lch && ch != uch) + next + else { + ch = Memc[ip+nchars] + if (ch != ' ' && ch != '=') + next + } + + # First char matches; check rest of string. + do i = 1, nchars-1 { + ch = Memc[ip+i] + if (ch != Memc[lkey+i] && ch != Memc[ukey+i]) { + ch = 0 + break + } + } + if (ch != 0) { + rp = ip # match + break + } + + recno = recno + 1 + } + } + + call sfree (sp) + if (rp == NULL) + return (0) + else + return (recno) +end diff --git a/sys/imfort/db/idbgstr.x b/sys/imfort/db/idbgstr.x new file mode 100644 index 00000000..0b997884 --- /dev/null +++ b/sys/imfort/db/idbgstr.x @@ -0,0 +1,78 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "idb.h" + +define TY_STRING (-1) + +# IDB_GETSTRING -- Get the string value of a standard header parameter. If the +# actual type of the parameter is not string the value is encoded as a string. +# The length of the string is returned as the function value. ERR is returned +# if the string cannot be found. + +int procedure idb_getstring (im, key, outstr, maxch) + +pointer im # image descriptor +char key[ARB] # parameter to be returned +char outstr[ARB] # output string to receive parameter value +int maxch + +long lval +double dval +int dtype, axis +int gstrcpy(), idb_kwlookup(), idb_naxis(), ltoc(), dtoc() +define encode_ 91 + +begin + # The keywords "naxis1", "naxis2", etc. are treated as a special case. + if (idb_naxis (key, axis) == YES) + if (axis > 0) { + dtype = TY_LONG + lval = IM_LEN(im,axis) + goto encode_ + } + + switch (idb_kwlookup (key)) { + case I_CTIME: + dtype = TY_LONG + lval = IM_CTIME(im) + case I_LIMTIME: + dtype = TY_LONG + lval = IM_LIMTIME(im) + case I_MAXPIXVAL: + dtype = TY_REAL + if (IS_INDEFR (IM_MAX(im))) + dval = INDEFD + else + dval = IM_MAX(im) + case I_MINPIXVAL: + dtype = TY_REAL + if (IS_INDEFR (IM_MIN(im))) + dval = INDEFD + else + dval = IM_MIN(im) + case I_MTIME: + dtype = TY_LONG + lval = IM_MTIME(im) + case I_NAXIS: + dtype = TY_LONG + lval = IM_NDIM(im) + case I_PIXFILE: + return (gstrcpy (IM_PIXFILE(im), outstr, maxch)) + case I_PIXTYPE: + dtype = TY_LONG + lval = IM_PIXTYPE(im) + case I_TITLE: + return (gstrcpy (IM_TITLE(im), outstr, maxch)) + default: + outstr[1] = EOS + return (ERR) + } + +encode_ + if (dtype == TY_LONG) + return (ltoc (lval, outstr, maxch)) + else + return (dtoc (dval, outstr, maxch, 15, 'g', maxch)) +end diff --git a/sys/imfort/db/idbkwlu.x b/sys/imfort/db/idbkwlu.x new file mode 100644 index 00000000..4f56e033 --- /dev/null +++ b/sys/imfort/db/idbkwlu.x @@ -0,0 +1,52 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "idb.h" + +# IDB_KWLOOKUP -- Look up a keyword in the dictionary of standard header +# keywords, returning the magic integer code of the keyword or zero. + +int procedure idb_kwlookup (key) + +char key[ARB] # keyword to be looked up +int index, ip, ch +pointer sp, kwname +int strdic(), strncmp(), strlen() +string keywords "|ctime|mtime|limtime|datamin|datamax|naxis\ +|pixfile|pixtype|title|" + +begin + call smark (sp) + call salloc (kwname, SZ_FNAME, TY_CHAR) + + # Look the string up in the dictionary of standard keywords. Note that + # the "i_" prefix is omitted in the dictionary. Minimum match abbrev. + # are permitted. The order of the keywords in the dictionary must + # agree with the defined codes in the header file. A standard keyword + # is recognized with or without the "i_" prefix. + + if (key[1] == 'i' && key[2] == '_') + ip = 3 + else + ip = 1 + + # Check for a reference to one of the NAXIS keywords. + if (key[ip] == 'n') + if (strncmp (key[ip], "naxis", 5) == 0) { + ch = key[ip+5] + if (ch == EOS || IS_DIGIT(ch)) { + call sfree (sp) + return (I_NAXIS) + } + } + + # Look up keyword in dictionary. Abbreviations are not permitted. + index = strdic (key[ip], Memc[kwname], SZ_FNAME, keywords) + if (index != 0) + if (strlen(key[ip]) != strlen(Memc[kwname])) + index = 0 + + call sfree (sp) + return (index) +end diff --git a/sys/imfort/db/idbnaxis.x b/sys/imfort/db/idbnaxis.x new file mode 100644 index 00000000..3b898403 --- /dev/null +++ b/sys/imfort/db/idbnaxis.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IDB_NAXIS -- Determine if the named keyword is one of the NAXIS* keywords, +# and if so return the value of the numeric suffix. + +int procedure idb_naxis (keyw, axnum) + +char keyw[ARB] # keyword name +int axnum # receives numeric axis code (0=no suffix) + +int ch, ip +int strncmp(), ctoi() + +begin + if (strncmp (keyw, "i_naxis", 7) == 0) + ip = 8 + else if (strncmp (keyw, "naxis", 5) == 0) + ip = 6 + else + return (NO) + + ch = keyw[ip] + if (!IS_DIGIT(ch) && ch != ' ' && ch != EOS) + return (NO) + + if (ctoi (keyw, ip, axnum) <= 0) + axnum = 0 + + return (YES) +end diff --git a/sys/imfort/db/idbpstr.x b/sys/imfort/db/idbpstr.x new file mode 100644 index 00000000..35835730 --- /dev/null +++ b/sys/imfort/db/idbpstr.x @@ -0,0 +1,96 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include "idb.h" + +# IDB_PUTSTRING -- Set the value of a standard header parameter given the new +# value of the parameter encoded as a string. If actual type of the parameter +# is non string the value must be decoded. ERR is returned if the key is not +# a standard header parameter or if the key is known but the value cannot be +# decoded. + +int procedure idb_putstring (im, key, strval) + +pointer im # image descriptor +char key[ARB] # parameter to be returned +char strval[ARB] # string value of parameter + +long lval +double dval +bool numeric +int ip, axis +int idb_kwlookup(), idb_naxis(), ctod() +long clktime() + +begin + ip = 1 + numeric = (ctod (strval, ip, dval) > 0) + if (numeric) { + if (IS_INDEFD (dval)) + lval = INDEFL + else if (real(MAX_LONG) < abs(dval)) + lval = INDEFL + else + lval = nint (dval) + } + + # The keywords "naxis1", "naxis2", etc. are treated as a special case. + if (idb_naxis (key, axis) == YES) + if (axis > 0) { + if (numeric) + IM_LEN(im,axis) = lval + else + return (ERR) + } + + # Lookup the keyword in the dictionary and set the value of the + # header parameter. If the parameter is string valued copy the + # string value and return immediately. + + switch (idb_kwlookup (key)) { + case I_CTIME: + if (numeric) + IM_CTIME(im) = lval + case I_LIMTIME: + if (numeric) + IM_LIMTIME(im) = lval + case I_MAXPIXVAL: + if (numeric) { + IM_MAX(im) = dval + IM_LIMTIME(im) = clktime (long(0)) + } + case I_MINPIXVAL: + if (numeric) { + IM_MIN(im) = dval + IM_LIMTIME(im) = clktime (long(0)) + } + case I_MTIME: + if (numeric) + IM_MTIME(im) = lval + case I_NAXIS: + if (numeric) + IM_NDIM(im) = lval + case I_PIXFILE: + call strcpy (strval, IM_PIXFILE(im), SZ_IMPIXFILE) + return (OK) + case I_PIXTYPE: + if (numeric) + IM_PIXTYPE(im) = lval + case I_TITLE: + call strcpy (strval, IM_TITLE(im), SZ_IMTITLE) + return (OK) + default: + return (ERR) + } + + # We make it here only if the actual keyword is numeric, so return + # ERR if the keyword value was nonnumeric. + + if (numeric) + return (OK) + else + return (ERR) +end diff --git a/sys/imfort/db/imaccf.x b/sys/imfort/db/imaccf.x new file mode 100644 index 00000000..60e4e9f3 --- /dev/null +++ b/sys/imfort/db/imaccf.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMACCF -- Test if the named field exists. NO is returned if the key is not +# found, YES otherwise. + +int procedure imaccf (im, key) + +pointer im # image descriptor +char key[ARB] # name of the new parameter +int idb_kwlookup(), idb_findrecord() +pointer rp + +begin + if ((idb_kwlookup (key) > 0) || (idb_findrecord (im, key, rp) > 0)) + return (YES) + else + return (NO) +end diff --git a/sys/imfort/db/imaddb.x b/sys/imfort/db/imaddb.x new file mode 100644 index 00000000..a3161377 --- /dev/null +++ b/sys/imfort/db/imaddb.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMADDB -- Add a new field to the image header and initialize to the value +# given. It is not an error if the parameter already exists. + +procedure imaddb (im, key, value, comment) + +pointer im # image descriptor +char key[ARB] # parameter or field value +bool value # new or initial value of parameter +char comment[ARB] # comment describing new parameter + +int imaccf() +errchk imaccf, imaddf + +begin + if (imaccf (im, key) == NO) + call imaddf (im, key, TY_BOOL, comment) + call imputb (im, key, value) +end diff --git a/sys/imfort/db/imaddd.x b/sys/imfort/db/imaddd.x new file mode 100644 index 00000000..55a6f591 --- /dev/null +++ b/sys/imfort/db/imaddd.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMADDD -- Add a new field to the image header and initialize to the value +# given. It is not an error if the parameter already exists. + +procedure imaddd (im, key, value, comment) + +pointer im # image descriptor +char key[ARB] # parameter or field value +double value # new or initial value of parameter +char comment[ARB] # comment describing new parameter + +int imaccf() +errchk imaccf, imaddf + +begin + if (imaccf (im, key) == NO) + call imaddf (im, key, TY_DOUBLE, comment) + call imputd (im, key, value) +end diff --git a/sys/imfort/db/imaddf.x b/sys/imfort/db/imaddf.x new file mode 100644 index 00000000..e6bda15e --- /dev/null +++ b/sys/imfort/db/imaddf.x @@ -0,0 +1,76 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "../imfort.h" +include "idb.h" + +# IMADDF -- Add a user field to the image header. It is an error if the named +# field already exists. + +procedure imaddf (im, key, datatype, comment) + +pointer im # image descriptor +char key[ARB] # name of the new parameter +int datatype # datatype of parameter +char comment[ARB] # comment describing new parameter + +int max_lenuserarea +pointer sp, keyname, rp, ua, op +int idb_kwlookup(), idb_findrecord(), strlen() +errchk syserrs + +begin + call smark (sp) + call salloc (keyname, SZ_FNAME, TY_CHAR) + + # FITS format requires that the keyword name be upper case. + call strcpy (key, Memc[keyname], SZ_FNAME) + call strupr (Memc[keyname]) + + # Check for a redefinition. + if ((idb_kwlookup (key) > 0) || (idb_findrecord (im, key, rp) > 0)) + call syserrs (SYS_IDBREDEF, key) + + # Open the user area string for appending. If the user area is not + # empty the last character must be the newline record delimiter, + # else the new record we add will be invalid. + + max_lenuserarea = (LEN_IMDES + IM_LENHDRMEM(im) - IMU + 1) * SZ_STRUCT + ua = IM_USERAREA(im) + + for (rp=ua; Memc[rp] != EOS; rp=rp+1) + ; + if (rp - ua + IDB_RECLEN + 1 >= max_lenuserarea) + call syserrs (SYS_IDBOVFL, key) + + if (rp > ua && Memc[rp-1] != '\n') { + Memc[rp] = '\n' + rp = rp + 1 + } + + # Append the new record with an uninitialized value field. Keyword + # value pairs are encoded in FITS format. + + do op = rp, rp + IDB_RECLEN # blank fill card + Memc[op] = ' ' + + # Add the "= 'value' / comment". + call amovc (Memc[keyname], Memc[rp], strlen(Memc[keyname])) + Memc[rp+9-1] = '=' + if (datatype == TY_CHAR) { + Memc[rp+11-1] = '\'' + Memc[rp+20-1] = '\'' + } + + # Add the comment field. + Memc[rp+32-1] = '/' + call amovc (comment, Memc[rp+34-1], + min (IDB_RECLEN-34+1, strlen(comment))) + + # Terminate the card. + Memc[rp+IDB_RECLEN] = '\n' + Memc[rp+IDB_RECLEN+1] = EOS + + call sfree (sp) +end diff --git a/sys/imfort/db/imaddi.x b/sys/imfort/db/imaddi.x new file mode 100644 index 00000000..527baaf0 --- /dev/null +++ b/sys/imfort/db/imaddi.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMADDI -- Add a new field to the image header and initialize to the value +# given. It is not an error if the parameter already exists. + +procedure imaddi (im, key, value, comment) + +pointer im # image descriptor +char key[ARB] # parameter or field value +int value # new or initial value of parameter +char comment[ARB] # comment describing new parameter + +int imaccf() +errchk imaccf, imaddf + +begin + if (imaccf (im, key) == NO) + call imaddf (im, key, TY_INT, comment) + call imputi (im, key, value) +end diff --git a/sys/imfort/db/imaddl.x b/sys/imfort/db/imaddl.x new file mode 100644 index 00000000..a707eab3 --- /dev/null +++ b/sys/imfort/db/imaddl.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMADDL -- Add a new field to the image header and initialize to the value +# given. It is not an error if the parameter already exists. + +procedure imaddl (im, key, value, comment) + +pointer im # image descriptor +char key[ARB] # parameter or field value +long value # new or initial value of parameter +char comment[ARB] # comment describing new parameter + +int imaccf() +errchk imaccf, imaddf + +begin + if (imaccf (im, key) == NO) + call imaddf (im, key, TY_LONG, comment) + call imputl (im, key, value) +end diff --git a/sys/imfort/db/imaddr.x b/sys/imfort/db/imaddr.x new file mode 100644 index 00000000..ad4eee81 --- /dev/null +++ b/sys/imfort/db/imaddr.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMADDR -- Add a new field to the image header and initialize to the value +# given. It is not an error if the parameter already exists. + +procedure imaddr (im, key, value, comment) + +pointer im # image descriptor +char key[ARB] # parameter or field value +real value # new or initial value of parameter +char comment[ARB] # comment describing new parameter + +int imaccf() +errchk imaccf, imaddf + +begin + if (imaccf (im, key) == NO) + call imaddf (im, key, TY_REAL, comment) + call imputr (im, key, value) +end diff --git a/sys/imfort/db/imadds.x b/sys/imfort/db/imadds.x new file mode 100644 index 00000000..b4a01595 --- /dev/null +++ b/sys/imfort/db/imadds.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMADDS -- Add a new field to the image header and initialize to the value +# given. It is not an error if the parameter already exists. + +procedure imadds (im, key, value, comment) + +pointer im # image descriptor +char key[ARB] # parameter or field value +short value # new or initial value of parameter +char comment[ARB] # comment describing new parameter + +int imaccf() +errchk imaccf, imaddf + +begin + if (imaccf (im, key) == NO) + call imaddf (im, key, TY_SHORT, comment) + call imputs (im, key, value) +end diff --git a/sys/imfort/db/imastr.x b/sys/imfort/db/imastr.x new file mode 100644 index 00000000..03736f38 --- /dev/null +++ b/sys/imfort/db/imastr.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMASTR -- Add a new field to the image header and initialize to the value +# given. It is not an error if the parameter already exists. + +procedure imastr (im, key, value, comment) + +pointer im # image descriptor +char key[ARB] # parameter or field value +char value[ARB] # new or initial value of parameter +char comment[ARB] # comment string +int imaccf() + +begin + if (imaccf (im, key) == NO) + call imaddf (im, key, TY_CHAR, comment) + call impstr (im, key, value) +end diff --git a/sys/imfort/db/imdelf.x b/sys/imfort/db/imdelf.x new file mode 100644 index 00000000..78be8a88 --- /dev/null +++ b/sys/imfort/db/imdelf.x @@ -0,0 +1,44 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "idb.h" + +# IMDELF -- Delete a user field from the image header. It is an error if the +# named field does not exist. + +procedure imdelf (im, key) + +pointer im # image descriptor +char key[ARB] # name of the new parameter + +int off +pointer rp, sp, keyname +int idb_kwlookup(), idb_findrecord(), stridxs() +errchk syserrs + +begin + call smark (sp) + call salloc (keyname, SZ_FNAME, TY_CHAR) + + # FITS format requires that the keyword name be upper case. + call strcpy (key, Memc[keyname], SZ_FNAME) + call strupr (Memc[keyname]) + + # Cannot delete standard header keywords. + if (idb_kwlookup (key) > 0) + call syserrs (SYS_IDBNODEL, key) + + # Verify that the named user field exists. + if (idb_findrecord (im, key, rp) <= 0) + call syserrs (SYS_IDBDELNXKW, key) + + # Delete the field. + off = stridxs ("\n", Memc[rp]) + if (off > 0) + call strcpy (Memc[rp+off], Memc[rp], ARB) + else + Memc[rp] = EOS + + call sfree (sp) +end diff --git a/sys/imfort/db/imgatr.x b/sys/imfort/db/imgatr.x new file mode 100644 index 00000000..5d600cfa --- /dev/null +++ b/sys/imfort/db/imgatr.x @@ -0,0 +1,51 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "idb.h" + +# IMGATR -- Get the attribute fields (type code and comment) of a header +# keyword. A separate, normally typed, call is required to get the keyword +# value. + +procedure imgatr (im, key, dtype, comm, maxch) + +pointer im # image descriptor +char key[ARB] # parameter to be returned +int dtype # receives datatype code +char comm[ARB] # output string to comment field +int maxch + +int op +pointer rp, ip +int idb_getstring(), idb_findrecord(), imgftype() +errchk syserrs, imgftype + +begin + # Get the field datatype. + dtype = imgftype (im, key) + + # Check for a standard header parameter first. + if (idb_getstring (im, key, comm, maxch) != ERR) { + comm[1] = EOS + return + } + + # Find the record. + if (idb_findrecord (im, key, rp) == 0) + call syserrs (SYS_IDBKEYNF, key) + + # Extract the comment field. + for (ip=rp+IDB_ENDVALUE; Memc[ip] != '/' && Memc[ip] != '\n'; ip=ip+1) + ; + if (Memc[ip] == '/') { + for (ip=ip+1; IS_WHITE(Memc[ip]); ip=ip+1) + ; + for (op=1; Memc[ip] != '\n'; ip=ip+1) { + comm[op] = Memc[ip] + op = op + 1 + } + comm[op] = EOS + } else + comm[1] = EOS +end diff --git a/sys/imfort/db/imgetb.x b/sys/imfort/db/imgetb.x new file mode 100644 index 00000000..aba16f97 --- /dev/null +++ b/sys/imfort/db/imgetb.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "idb.h" + +# IMGETB -- Get an image header parameter of type boolean. False is returned +# if the parameter cannot be found or if the value is not true. + +bool procedure imgetb (im, key) + +pointer im # image descriptor +char key[ARB] # parameter to be returned +pointer rp +pointer idb_findrecord() + +begin + if (idb_findrecord (im, key, rp) == 0) + return (false) + else + return (Memc[rp+IDB_ENDVALUE-1] == 'T') +end diff --git a/sys/imfort/db/imgetc.x b/sys/imfort/db/imgetc.x new file mode 100644 index 00000000..f56ecb9d --- /dev/null +++ b/sys/imfort/db/imgetc.x @@ -0,0 +1,13 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMGETC -- Get an image header parameter of type char. + +char procedure imgetc (im, key) + +pointer im # image descriptor +char key[ARB] # parameter to be returned +long imgetl() + +begin + return (imgetl (im, key)) +end diff --git a/sys/imfort/db/imgetd.x b/sys/imfort/db/imgetd.x new file mode 100644 index 00000000..01a71cb1 --- /dev/null +++ b/sys/imfort/db/imgetd.x @@ -0,0 +1,32 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "idb.h" + +# IMGETD -- Get an image header parameter of type double floating. If the +# named parameter is a standard parameter return the value directly, +# else scan the user area for the named parameter and decode the value. + +double procedure imgetd (im, key) + +pointer im # image descriptor +char key[ARB] # parameter to be returned + +int ip +double dval +pointer sp, sval +int ctod() +errchk syserrs, imgstr + +begin + call smark (sp) + call salloc (sval, SZ_LINE, TY_CHAR) + + ip = 1 + call imgstr (im, key, Memc[sval], SZ_LINE) + if (ctod (Memc[sval], ip, dval) == 0) + call syserrs (SYS_IDBTYPE, key) + + call sfree (sp) + return (dval) +end diff --git a/sys/imfort/db/imgeti.x b/sys/imfort/db/imgeti.x new file mode 100644 index 00000000..8da2878e --- /dev/null +++ b/sys/imfort/db/imgeti.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMGETI -- Get an image header parameter of type integer. + +int procedure imgeti (im, key) + +pointer im # image descriptor +char key[ARB] # parameter to be returned + +long lval, imgetl() +errchk imgetl + +begin + lval = imgetl (im, key) + if (IS_INDEFL(lval)) + return (INDEFI) + else + return (lval) +end diff --git a/sys/imfort/db/imgetl.x b/sys/imfort/db/imgetl.x new file mode 100644 index 00000000..817715c0 --- /dev/null +++ b/sys/imfort/db/imgetl.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMGETL -- Get an image header parameter of type long integer. + +long procedure imgetl (im, key) + +pointer im # image descriptor +char key[ARB] # parameter to be returned + +double dval, imgetd() +errchk imgetd + +begin + dval = imgetd (im, key) + if (IS_INDEFD(dval)) + return (INDEFL) + else + return (nint (dval)) +end diff --git a/sys/imfort/db/imgetr.x b/sys/imfort/db/imgetr.x new file mode 100644 index 00000000..b1c6c67a --- /dev/null +++ b/sys/imfort/db/imgetr.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMGETR -- Get an image header parameter of type real. + +real procedure imgetr (im, key) + +pointer im # image descriptor +char key[ARB] # parameter to be returned + +double dval, imgetd() +errchk imgetd + +begin + dval = imgetd (im, key) + if (IS_INDEFD(dval)) + return (INDEFR) + else + return (dval) +end diff --git a/sys/imfort/db/imgets.x b/sys/imfort/db/imgets.x new file mode 100644 index 00000000..39f2fcfd --- /dev/null +++ b/sys/imfort/db/imgets.x @@ -0,0 +1,19 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMGETS -- Get an image header parameter of type short integer. + +short procedure imgets (im, key) + +pointer im # image descriptor +char key[ARB] # parameter to be returned + +long lval, imgetl() +errchk imgetl + +begin + lval = imgetl (im, key) + if (IS_INDEFL(lval)) + return (INDEFS) + else + return (lval) +end diff --git a/sys/imfort/db/imgftype.x b/sys/imfort/db/imgftype.x new file mode 100644 index 00000000..246219d5 --- /dev/null +++ b/sys/imfort/db/imgftype.x @@ -0,0 +1,76 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "idb.h" + +# IMGFTYPE -- Get the datatype of a particular field of an image header. Since +# the internal format is FITS, there are four primary datatypes, boolean (T|F), +# string (quoted), integer and real. + +int procedure imgftype (im, key) + +pointer im # image descriptor +char key[ARB] # parameter to be set + +pointer rp +int axis, ch, ip +int idb_findrecord(), idb_kwlookup(), idb_naxis() +errchk syserrs + +begin + # The standard header keywords "naxis1", "naxis2", etc. are treated + # as a special case. + + if (idb_naxis (key, axis) == YES) + return (TY_LONG) + + # Handle the standard header keywords. + + switch (idb_kwlookup (key)) { + case I_CTIME: + return (TY_LONG) + case I_LIMTIME: + return (TY_LONG) + case I_MAXPIXVAL: + return (TY_REAL) + case I_MINPIXVAL: + return (TY_REAL) + case I_MTIME: + return (TY_LONG) + case I_NAXIS: + return (TY_LONG) + case I_PIXFILE: + return (TY_CHAR) + case I_PIXTYPE: + return (TY_LONG) + case I_TITLE: + return (TY_CHAR) + } + + # If we get here then the named parameter is not a standard header + # keyword. + + if (idb_findrecord (im, key, rp) > 0) { + # Check for quoted string. + ch = Memc[rp+IDB_STARTVALUE] + if (ch == '\'') + return (TY_CHAR) + + # Check for boolean field. + ch = Memc[rp+IDB_ENDVALUE-1] + if (ch == 'T' || ch == 'F') + return (TY_BOOL) + + # If field contains only digits it must be an integer. + for (ip=IDB_STARTVALUE; ip <= IDB_ENDVALUE; ip=ip+1) { + ch = Memc[rp+ip-1] + if (! (IS_DIGIT(ch) || IS_WHITE(ch))) + return (TY_REAL) + } + + return (TY_INT) + } + + call syserrs (SYS_IDBKEYNF, key) +end diff --git a/sys/imfort/db/imgnfn.x b/sys/imfort/db/imgnfn.x new file mode 100644 index 00000000..88969645 --- /dev/null +++ b/sys/imfort/db/imgnfn.x @@ -0,0 +1,338 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include "../imfort.h" +include "idb.h" + +.help imgnfn +.nf -------------------------------------------------------------------------- +IMGNFN -- Template expansion for header keywords. + + list = imofnl[su] (im, template) # open list + nch = imgnfn (im, outstr, maxch) # get next field name + imcfnl (im) # close list + +IMOFNLS opens the list sorted, whereas IMOFNLU opens it unsorted. Both std. +and user header keywords are included in the list. +.endhelp --------------------------------------------------------------------- + +define MAX_FIELDS 128 +define SZ_SBUF 1024 +define LEN_FNSTRUCT (10+MAX_FIELDS) + +define FN_NENTRIES Memi[$1] # number of field names in list +define FN_NEXT Memi[$1+1] # next string to be returned +define FN_SBUF Memi[$1+2] # pointer to string buffer + # open +define FN_STRP Memi[$1+10+$2-1] # array of str ptrs +define FN_FIELDNAME Memc[FN_STRP($1,$2)] # reference a string + + +# IMGNFN -- Get the next header field name matching the given template from an +# image header database. Sorting of the field list is optional. A prior call +# to IMOFNL[SU] is necessary to open the sorted or unsorted list. + +int procedure imgnfn (fn, outstr, maxch) + +pointer fn # field name list descriptor +char outstr[ARB] # output string +int maxch + +int strnum +int gstrcpy() + +begin + strnum = FN_NEXT(fn) + if (strnum > FN_NENTRIES(fn)) + return (EOF) + FN_NEXT(fn) = strnum + 1 + + return (gstrcpy (FN_FIELDNAME(fn,strnum), outstr, maxch)) +end + + +# IMOFNLS -- Open a sorted field name list. + +pointer procedure imofnls (im, template) + +pointer im # image descriptor +char template[ARB] # field name template +pointer imofnl() + +begin + return (imofnl (im, template, YES)) +end + + +# IMOFNLU -- Open an unsorted field name list. + +pointer procedure imofnlu (im, template) + +pointer im # image descriptor +char template[ARB] # field name template +pointer imofnl() + +begin + return (imofnl (im, template, NO)) +end + + +# IMCFNL -- Close the image header field name list and return all associated +# storage. + +procedure imcfnl (fn) + +pointer fn # field name list descriptor + +begin + call mfree (FN_SBUF(fn), TY_CHAR) + call mfree (fn, TY_STRUCT) +end + + +# IMOFNL -- Open an image header field name list, either sorted or unsorted. +# A template is a list of patterns delimited by commas. + +pointer procedure imofnl (im, template, sort) + +pointer im # image descriptor +char template[ARB] # field name template +int sort # sort flag + +bool escape +int tp, nstr, ch, junk, first_string, nstrings, nmatch, i +pointer sp, ip, op, fn, kwname, sbuf, pattern, patcode, nextch +int patmake(), patmatch(), strlen() +errchk syserr + +begin + call smark (sp) + call salloc (kwname, SZ_FNAME, TY_CHAR) + call salloc (pattern, SZ_FNAME, TY_CHAR) + call salloc (patcode, SZ_LINE, TY_CHAR) + + # Allocate field list descriptor. + call calloc (fn, LEN_FNSTRUCT, TY_STRUCT) + call malloc (sbuf, SZ_SBUF, TY_CHAR) + + FN_SBUF(fn) = sbuf + nextch = sbuf + nstr = 0 + tp = 1 + + # Extract each comma delimited template, expand upon image header + # field list, sort if desired, and add strings to list. + + while (template[tp] != EOS && template[tp] != '\n') { + # Advance to next field. + while (IS_WHITE(template[tp]) || template[tp] == ',') + tp = tp + 1 + + # Extract pattern. Enclose pattern in ^{} so that the match will + # occur only at the beginning of each line and will be case + # insensitive (req'd for FITS format). + + op = pattern + Memc[op] = '^' + op = op + 1 + Memc[op] = '{' + op = op + 1 + + # A field name of the form "$", "$x", etc. is not matched against + # the actual image field list, but is included in the output field + # list as a literal. + + ch = template[tp] + escape = (ch == '$') + + while (! (IS_WHITE(ch) || ch == '\n' || ch == ',' || ch == EOS)) { + # Map "*" into "?*". + if (ch == '*') { + Memc[op] = '?' + op = op + 1 + } + + Memc[op] = ch + op = op + 1 + tp = tp + 1 + ch = template[tp] + } + + Memc[op] = '}' + op = op + 1 + Memc[op] = EOS + + # If the pattern is a literal, put it in the output list without + # matching it against the image field list. + + if (escape) { + # Omit the leading "^{" and the trailing "}". + ip = pattern + 2 + op = op - 1 + Memc[op] = EOS + call imfn_putkey (Memc[ip], FN_STRP(fn,1), nstr, nextch, sbuf) + + } else { + # Encode pattern. + junk = patmake (Memc[pattern], Memc[patcode], SZ_LINE) + + # Scan database and extract all field names matching the + # pattern. Mark number of first string for the sort. + + first_string = nstr + 1 + + # First find any standard header keywords matching the pattern. + call imfn_stdkeys (im, Memc[patcode], FN_STRP(fn,1), nstr, + nextch, sbuf) + + # Now scan the user area. + for (ip=IM_USERAREA(im); Memc[ip] != EOS; ip=ip+1) { + # Skip entries that are not keywords. + if (Memc[ip+8] != '=') + next + + # Extract keyword name. + Memc[kwname+8] = EOS + do i = 1, 8 { + ch = Memc[ip+i-1] + if (ch == ' ') { + Memc[kwname+i-1] = EOS + break + } else + Memc[kwname+i-1] = ch + } + + # Check for a match. + if (Memc[kwname] != EOS) { + # Put key in list if it matches. + nmatch = patmatch (Memc[kwname], Memc[patcode]) - 1 + if (nmatch > 0 && nmatch == strlen(Memc[kwname])) + call imfn_putkey (Memc[ip], + FN_STRP(fn,1), nstr, nextch, sbuf) + } + + # Advance to the next record. + if (IM_UABLOCKED(im) == YES) + ip = ip + IDB_RECLEN + else { + while (Memc[ip] != '\n' && Memc[ip] != EOS) + ip = ip + 1 + } + + if (Memc[ip] == EOS) + break + } + + # Sort the newly added keywords. + nstrings = nstr - first_string + 1 + if (sort == YES && nstrings > 1) + call strsrt (FN_STRP(fn,first_string), Memc, nstrings) + } + } + + FN_NENTRIES(fn) = nstr + FN_NEXT(fn) = 1 + + call sfree (sp) + return (fn) +end + + +# IMFN_STDKEYS -- Match a pattern (encoded) against the list of standard header +# keywords, both with and without the "i_" prefix. Add the full name (with i_ +# prefix) of each name matched to the keyword list. Note that by default, +# only the "user" keywords are matched in this way, although any keyword can +# be accessed if its name is known (i.e., not all keywords are visible). + +procedure imfn_stdkeys (im, patcode, strp, nstr, nextch, sbuf) + +pointer im # image descriptor +char patcode[ARB] # encoded pattern +pointer strp[ARB] # array of string pointers +int nstr # current number of strings +pointer nextch # next available char in string buffer +pointer sbuf # string buffer + +bool validfield +int ip, index +pointer sp, op, key +int patmatch() +errchk imfn_putkey + +# NOTE index values below depend upon position in this string. +string keywords "|naxis|naxis1|naxis2|naxis3|pixtype|datamin|datamax|\ +ctime|mtime|limtime|title|" + +begin + call smark (sp) + call salloc (key, SZ_FNAME, TY_CHAR) + + call strcpy ("i_", Memc[key], SZ_FNAME) + index = 1 + + for (ip=2; keywords[ip] != EOS; ip=ip+1) { + # Do not put dimensions NAXIS1, NAXIS2, etc. higher than the + # actual image dimension into the matched list. + + validfield = true + if (index >= 2 && index <= 4) + validfield = (index - 1 <= IM_NDIM(im)) + + # Extract keyword into buffer, after the "i_". + for (op=key+2; keywords[ip] != '|'; op=op+1) { + Memc[op] = keywords[ip] + ip = ip + 1 + } + Memc[op] = EOS + + if (validfield) + if (patmatch (Memc[key], patcode) > 0 || + patmatch (Memc[key+2], patcode) > 0) { + + call imfn_putkey (Memc[key], strp, nstr, nextch, sbuf) + } + + index = index + 1 + } + + call sfree (sp) +end + + +# IMFN_PUTKEY -- Put a keyword into the keyword list. + +procedure imfn_putkey (key, strp, nstr, nextch, sbuf) + +char key[ARB] # keyword name (etc.) +pointer strp[ARB] # array of string pointers +int nstr # current number of strings +pointer nextch # next available char in string buffer +pointer sbuf # string buffer + +int ch, ip +errchk syserr + +begin + # Append keyword to the string buffer. + nstr = nstr + 1 + if (nstr > MAX_FIELDS) + call syserr (SYS_IMFNOVFL) + strp[nstr] = nextch + + ip = 1 + ch = key[ip] + + while (ch != '=' && ch != ' ' && ch != EOS) { + Memc[nextch] = ch + nextch = nextch + 1 + if (nextch >= sbuf + SZ_SBUF) + call syserr (SYS_IMFNOVFL) + ip = ip + 1 + ch = key[ip] + } + + Memc[nextch] = EOS + nextch = nextch + 1 +end diff --git a/sys/imfort/db/imgstr.x b/sys/imfort/db/imgstr.x new file mode 100644 index 00000000..bf3272a5 --- /dev/null +++ b/sys/imfort/db/imgstr.x @@ -0,0 +1,41 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "idb.h" + +# IMGSTR -- Get an image header parameter of type string. If the named +# parameter is a standard parameter return the value directly, else scan +# the user area for the named parameter and decode the value. + +procedure imgstr (im, key, outstr, maxch) + +pointer im # image descriptor +char key[ARB] # parameter to be returned +char outstr[ARB] # output string to receive parameter value +int maxch + +pointer rp +int ip, op +int idb_getstring(), idb_findrecord(), ctowrd(), strlen() +errchk syserrs + +begin + # Check for a standard header parameter first. + if (idb_getstring (im, key, outstr, maxch) != ERR) + return + + # Find the record. + if (idb_findrecord (im, key, rp) == 0) + call syserrs (SYS_IDBKEYNF, key) + + ip = IDB_STARTVALUE + if (ctowrd (Memc[rp], ip, outstr, maxch) > 0) { + # Strip trailing whitespace. + op = strlen (outstr) + while (op > 0 && (IS_WHITE(outstr[op]) || outstr[op] == '\n')) + op = op - 1 + outstr[op+1] = EOS + } else + outstr[1] = EOS +end diff --git a/sys/imfort/db/impstr.x b/sys/imfort/db/impstr.x new file mode 100644 index 00000000..fba9f8af --- /dev/null +++ b/sys/imfort/db/impstr.x @@ -0,0 +1,72 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "idb.h" + +# IMPSTR -- Put an image header parameter of type string. If the named +# parameter is a standard parameter of type other than string, decode the +# string and set the binary value of the parameter. If the parameter is +# a nonstandard one we can do a simple string edit, since user parameters +# are stored in the user area in string form. The datatype of the parameter +# must be preserved by the edit, i.e., parameters of actual datatype string +# must be quoted and left justified and other parameters must be unquoted +# and right justified in the value field. + +procedure impstr (im, key, value) + +pointer im # image descriptor +char key[ARB] # parameter to be set +char value[ARB] # new parameter value + +pointer rp, ip, vp +int ncols, n, i +bool string_valued +int idb_putstring(), idb_findrecord(), strlen() +errchk syserrs + +begin + # Check for a standard header parameter first. + if (idb_putstring (im, key, value) != ERR) + return + + # Find the record. + if (idb_findrecord (im, key, rp) == 0) + call syserrs (SYS_IDBKEYNF, key) + + # Determine the actual datatype of the parameter. String valued + # parameters will have an apostrophe in the first nonblank column + # of the value field. + + string_valued = false + for (ip=IDB_STARTVALUE; ip <= IDB_ENDVALUE; ip=ip+1) + if (Memc[rp+ip-1] == '\'') { + string_valued = true + break + } + + vp = rp + IDB_STARTVALUE - 1 + n = strlen (value) + + # If we have a long string value, give it the whole card. + ncols = IDB_ENDVALUE - IDB_STARTVALUE + 1 + if (string_valued && n > 21 - 3) + ncols = IDB_RECLEN - IDB_STARTVALUE + 1 + + # Blank fill the value field. + do i = 1, ncols + Memc[vp+i-1] = ' ' + + # Encode the new value of the parameter in a field of width 21 + # (or larger in the case of long string values) including a leading + # blank and the quotes if string valued. + + if (string_valued) { + n = min (ncols - 3, n) + Memc[vp+2-1] = '\'' + call amovc (value, Memc[vp+3-1], n) + Memc[vp+ncols-1] = '\'' + } else { + n = min (ncols - 1, n) + call amovc (value, Memc[vp+ncols-1-n+1], n) + } +end diff --git a/sys/imfort/db/imputb.x b/sys/imfort/db/imputb.x new file mode 100644 index 00000000..a211f464 --- /dev/null +++ b/sys/imfort/db/imputb.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMPUTB -- Put an image header parameter of type boolean. + +procedure imputb (im, key, bval) + +pointer im # image descriptor +char key[ARB] # parameter to be set +bool bval # parameter value +char sval[2] + +begin + if (bval) + sval[1] = 'T' + else + sval[1] = 'F' + sval[2] = EOS + + call impstr (im, key, sval) +end diff --git a/sys/imfort/db/imputd.x b/sys/imfort/db/imputd.x new file mode 100644 index 00000000..fc633c23 --- /dev/null +++ b/sys/imfort/db/imputd.x @@ -0,0 +1,37 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include + +# IMPUTD -- Put an image header parameter of type double. + +procedure imputd (im, key, dval) + +pointer im # image descriptor +char key[ARB] # parameter to be set +double dval # double precision value + +int junk, i +pointer sp, sval +int dtoc(), strlen() + +begin + call smark (sp) + call salloc (sval, SZ_FNAME, TY_CHAR) + + # Reduce the precision of the encoded value if necessary to fit in + # the FITS value field. Start with NDIGITS_DP-1 as the precision + # estimate NDIGITS_DP is only approximate, and if we make up half a + # digit of precision the result can be 1.00000000000000001 instead + # of 1.0. + + for (i=NDIGITS_DP-1; i >= NDIGITS_RP; i=i-1) { + junk = dtoc (dval, Memc[sval], SZ_FNAME, i, 'g', SZ_FNAME) + if (strlen (Memc[sval]) < 20) + break + } + + # Write the new value to the header. + call impstr (im, key, Memc[sval]) + + call sfree (sp) +end diff --git a/sys/imfort/db/imputi.x b/sys/imfort/db/imputi.x new file mode 100644 index 00000000..a4ccdd31 --- /dev/null +++ b/sys/imfort/db/imputi.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMPUTI -- Put an image header parameter of type integer. + +procedure imputi (im, key, ival) + +pointer im # image descriptor +char key[ARB] # parameter to be set +int ival # parameter value +long lval + +begin + if (IS_INDEFI (ival)) + lval = INDEFL + else + lval = ival + call imputl (im, key, lval) +end diff --git a/sys/imfort/db/imputl.x b/sys/imfort/db/imputl.x new file mode 100644 index 00000000..3af988a9 --- /dev/null +++ b/sys/imfort/db/imputl.x @@ -0,0 +1,23 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMPUTL -- Put an image header parameter of type long integer. + +procedure imputl (im, key, lval) + +pointer im # image descriptor +char key[ARB] # parameter to be set +long lval # parameter value + +int junk +pointer sp, sval +int ltoc() + +begin + call smark (sp) + call salloc (sval, SZ_FNAME, TY_CHAR) + + junk = ltoc (lval, Memc[sval], SZ_FNAME) + call impstr (im, key, Memc[sval]) + + call sfree (sp) +end diff --git a/sys/imfort/db/imputr.x b/sys/imfort/db/imputr.x new file mode 100644 index 00000000..27668a62 --- /dev/null +++ b/sys/imfort/db/imputr.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMPUTR -- Put an image header parameter of type real. + +procedure imputr (im, key, rval) + +pointer im # image descriptor +char key[ARB] # parameter to be set +real rval # parameter value +double dval + +begin + if (IS_INDEFR (rval)) + dval = INDEFD + else + dval = rval + call imputd (im, key, dval) +end diff --git a/sys/imfort/db/imputs.x b/sys/imfort/db/imputs.x new file mode 100644 index 00000000..6b0f763f --- /dev/null +++ b/sys/imfort/db/imputs.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# IMPUTS -- Put an image header parameter of type short integer. + +procedure imputs (im, key, sval) + +pointer im # image descriptor +char key[ARB] # parameter to be set +short sval # parameter value +long lval + +begin + if (IS_INDEFS (sval)) + lval = INDEFL + else + lval = sval + call imputl (im, key, lval) +end diff --git a/sys/imfort/db/mkpkg b/sys/imfort/db/mkpkg new file mode 100644 index 00000000..4ce6acd4 --- /dev/null +++ b/sys/imfort/db/mkpkg @@ -0,0 +1,42 @@ +# Update the IMFORT image header database interface. + +$checkout libimfort.a lib$ +$update libimfort.a +$checkin libimfort.a lib$ +$exit + +libimfort.a: + idbfind.x ../imfort.h idb.h + idbgstr.x idb.h + idbkwlu.x idb.h + idbnaxis.x + idbpstr.x idb.h + imaccf.x + imaddb.x + imaddd.x + imaddf.x ../imfort.h idb.h + imaddi.x + imaddl.x + imaddr.x + imadds.x + imastr.x + imdelf.x idb.h + imgatr.x idb.h + imgetb.x idb.h + imgetc.x + imgetd.x idb.h + imgeti.x + imgetl.x + imgetr.x + imgets.x + imgftype.x idb.h + imgnfn.x ../imfort.h idb.h + imgstr.x idb.h + impstr.x idb.h + imputb.x + imputd.x + imputi.x + imputl.x + imputr.x + imputs.x + ; -- cgit