diff options
author | Joe Hunkeler <jhunkeler@gmail.com> | 2015-08-11 16:51:37 -0400 |
---|---|---|
committer | Joe Hunkeler <jhunkeler@gmail.com> | 2015-08-11 16:51:37 -0400 |
commit | 40e5a5811c6ffce9b0974e93cdd927cbcf60c157 (patch) | |
tree | 4464880c571602d54f6ae114729bf62a89518057 /noao/digiphot/lib | |
download | iraf-osx-40e5a5811c6ffce9b0974e93cdd927cbcf60c157.tar.gz |
Repatch (from linux) of OSX IRAF
Diffstat (limited to 'noao/digiphot/lib')
-rw-r--r-- | noao/digiphot/lib/mkpkg | 11 | ||||
-rw-r--r-- | noao/digiphot/lib/ptkeysdef.h | 77 | ||||
-rw-r--r-- | noao/digiphot/lib/pttables/Revisions | 10 | ||||
-rw-r--r-- | noao/digiphot/lib/pttables/mkpkg | 19 | ||||
-rw-r--r-- | noao/digiphot/lib/pttables/ptchoose.x | 164 | ||||
-rw-r--r-- | noao/digiphot/lib/pttables/ptfmkrec.x | 102 | ||||
-rw-r--r-- | noao/digiphot/lib/pttables/ptgetop.x | 112 | ||||
-rw-r--r-- | noao/digiphot/lib/pttables/ptgnfn.x | 239 | ||||
-rw-r--r-- | noao/digiphot/lib/pttables/pthdrs.x | 235 | ||||
-rw-r--r-- | noao/digiphot/lib/pttables/ptkeywords.x | 615 | ||||
-rw-r--r-- | noao/digiphot/lib/pttables/ptkid.x | 26 | ||||
-rw-r--r-- | noao/digiphot/lib/pttables/ptkstat.x | 137 | ||||
-rw-r--r-- | noao/digiphot/lib/pttables/ptmkrec.x | 86 | ||||
-rw-r--r-- | noao/digiphot/lib/pttables/ptranges.x | 38 |
14 files changed, 1871 insertions, 0 deletions
diff --git a/noao/digiphot/lib/mkpkg b/noao/digiphot/lib/mkpkg new file mode 100644 index 00000000..4e879108 --- /dev/null +++ b/noao/digiphot/lib/mkpkg @@ -0,0 +1,11 @@ +# Make the local DIGIPHOT libraries + +relink: +update: + +$update libpttables.a +$exit + +libpttables.a: + @pttables + ; diff --git a/noao/digiphot/lib/ptkeysdef.h b/noao/digiphot/lib/ptkeysdef.h new file mode 100644 index 00000000..9cb005ea --- /dev/null +++ b/noao/digiphot/lib/ptkeysdef.h @@ -0,0 +1,77 @@ +# Header file for apselect keywords + +define LEN_KEYSTRUCT 30 + +# numbers of keys + +define KY_NKEYS Memi[$1] # total number of keys +define KY_NPKEYS Memi[$1+1] # number of parameter keys +define KY_NSTORE Memi[$1+2] # amount of storage space for keys +#define KY_NOKEYS Memi[$1+3] # number of defined keys before table + +# keyword strings + +define LEN_KWORDS Memi[$1+4] # length of the keyword string +define KY_WORDS Memi[$1+5] # pointer to the keywords string +define KY_VALUES Memi[$1+6] # pointer to the values string +define KY_UNITS Memi[$1+7] # pointer to the units string +define KY_FORMATS Memi[$1+8] # pointer to the format string + +# indices + +define KY_PTRS Memi[$1+9] # pointer to values array +define KY_NELEMS Memi[$1+10] # pointer to number of elems array +define KY_TYPES Memi[$1+11] # pointer to the keyword data type array +define KY_KINDICES Memi[$1+12] # pointer to the keyword indices +define KY_UINDICES Memi[$1+13] # pointer to the unit indices +define KY_FINDICES Memi[$1+14] # pointer to the format indices +define KY_NPLINE Memi[$1+15] # pointer to values per line array +define KY_NCONTINUE Memi[$1+16] # pointer to max no of continuations + +# select buffers + +define KY_NSELECT Memi[$1+18] # number of selected keys +define KY_SELECT Memi[$1+19] # indices to selected fields +define KY_ELEM_SELECT Memi[$1+20] # index of element to be selected +define KY_LEN_SELECT Memi[$1+21] # lengths of the selected fields +define KY_NAME_SELECT Memi[$1+22] # pointer to string of selected names +define KY_UNIT_SELECT Memi[$1+23] # pointer to string of selected units +define KY_FMT_SELECT Memi[$1+24] # pointer to string of selected formats + + +# test for apphot/daophot database format + +define KY_CHAR_IRAF "^\#K IRAF" + +# some important character strings + +define KY_CHAR_KEYWORD "#K " +define KY_CHAR_NAME "#N " +define KY_CHAR_UNITS "#U " +define KY_CHAR_FORMAT "#F " +define KY_LEN_STR 3 + +define KY_CHAR_POUND '#' +define KY_CHAR_NEWLINE '\n' +define KY_CHAR_CONT '\\' + + +# some useful constants + +define KY_SZPAR 23 # assumed number of chars in a parameter +define KY_NPARS 50 # initial guess at number of parameters +define KY_NLINES 20 # maximum number of lines per record + +define KY_MAXNKEYWORDS 150 # maximum number of keywords. +#define KY_MAXNNAMES 150 # maximum number of column names +define KY_MAXNRANGES 150 # maximum number of reanges + +# names of parameter which can be extracted from the keys database + +define KY_INDEX 1 +define KY_DATATYPE 2 +define KY_LENGTH 3 +define KY_ELEMENT 4 +define KY_NUMELEMS 5 +define KY_UNITSTR 6 +define KY_FMTSTR 7 diff --git a/noao/digiphot/lib/pttables/Revisions b/noao/digiphot/lib/pttables/Revisions new file mode 100644 index 00000000..4fce2c60 --- /dev/null +++ b/noao/digiphot/lib/pttables/Revisions @@ -0,0 +1,10 @@ +.help revisions Jun94 noao.digiphot.pttables +.nf +pttables/ptkeywords.x + Fixed a memory allocation bug which occured when the number of + header keywords was greater the 50. A pointer array was not being + correctly updated after memory reallocation. + + (Davis, Feb 2, 1994) + +.endhelp diff --git a/noao/digiphot/lib/pttables/mkpkg b/noao/digiphot/lib/pttables/mkpkg new file mode 100644 index 00000000..af6f7827 --- /dev/null +++ b/noao/digiphot/lib/pttables/mkpkg @@ -0,0 +1,19 @@ +# Pttables library + +$checkout libpttables.a ".." +$update libpttables.a +$checkin libpttables.a ".." +$exit + +libpttables.a: + ptchoose.x ../ptkeysdef.h + ptfmkrec.x ../ptkeysdef.h + ptgetop.x ../ptkeysdef.h <evexpr.h> + ptgnfn.x ../ptkeysdef.h <ctype.h> <syserr.h> + pthdrs.x ../ptkeysdef.h + ptkeywords.x ../ptkeysdef.h + ptkid.x + ptkstat.x ../ptkeysdef.h + ptmkrec.x ../ptkeysdef.h + ptranges.x + ; diff --git a/noao/digiphot/lib/pttables/ptchoose.x b/noao/digiphot/lib/pttables/ptchoose.x new file mode 100644 index 00000000..18a35195 --- /dev/null +++ b/noao/digiphot/lib/pttables/ptchoose.x @@ -0,0 +1,164 @@ +include "../ptkeysdef.h" + +# PT_CHOOSE -- Determine which fields are to be selected. + +int procedure pt_choose (key, fields) + +pointer key # pointer to key structure +char fields[ARB] # fields to be evaluated + +int max_nkeys, nkeys, index, elems, nelems, element, len +pointer list, sp, kname, uname, fname, aranges, ranges, rangeset +pointer nop, uop, fop +int pt_gnfn(), pt_ranges(), strdic(), decode_ranges(), get_next_number() +int pt_kstati() +pointer pt_ofnl() +real asumi() + +begin + # Allocate buffer space + call smark (sp) + call salloc (kname, KY_SZPAR, TY_CHAR) + call salloc (uname, KY_SZPAR, TY_CHAR) + call salloc (fname, KY_SZPAR, TY_CHAR) + call salloc (aranges, SZ_FNAME, TY_CHAR) + call salloc (ranges, SZ_FNAME, TY_CHAR) + call salloc (rangeset, 3 * KY_MAXNRANGES + 1, TY_INT) + + # Allocate space for the select buffers. Space equal to the number + # of keys in the database is allocated. Allowance must be made for + # array subsripts. + + max_nkeys = int (asumi (Memi[KY_NELEMS(key)], KY_NKEYS(key))) + 1 + + if (KY_SELECT(key) != NULL) + call mfree (KY_SELECT(key), TY_INT) + call malloc (KY_SELECT(key), max_nkeys, TY_INT) + if (KY_ELEM_SELECT(key) != NULL) + call mfree (KY_ELEM_SELECT(key), TY_INT) + call malloc (KY_ELEM_SELECT(key), max_nkeys, TY_INT) + if (KY_LEN_SELECT(key) != NULL) + call mfree (KY_LEN_SELECT(key), TY_INT) + call malloc (KY_LEN_SELECT(key), max_nkeys, TY_INT) + + if (KY_NAME_SELECT(key) != NULL) + call mfree (KY_NAME_SELECT(key), TY_CHAR) + call malloc (KY_NAME_SELECT(key), max_nkeys * KY_SZPAR, TY_CHAR) + if (KY_UNIT_SELECT(key) != NULL) + call mfree (KY_UNIT_SELECT(key), TY_CHAR) + call malloc (KY_UNIT_SELECT(key), max_nkeys * KY_SZPAR, TY_CHAR) + if (KY_FMT_SELECT(key) != NULL) + call mfree (KY_FMT_SELECT(key), TY_CHAR) + call malloc (KY_FMT_SELECT(key), max_nkeys * KY_SZPAR, TY_CHAR) + + nop = KY_NAME_SELECT(key) + uop = KY_UNIT_SELECT(key) + fop = KY_FMT_SELECT(key) + nkeys = 0 + + # Loop through the fields list. + list = pt_ofnl (key, fields) + while (pt_gnfn (list, Memc[kname], Memc[aranges], KY_SZPAR) != EOF) { + + # Find the field name and the ranges. + index = strdic (Memc[kname], Memc[kname], KY_SZPAR, + Memc[KY_WORDS(key)]) + if (pt_ranges (Memc[aranges], Memc[ranges], element, + SZ_FNAME) == ERR) + call error (0, "Cannot decode apphot range string") + if (index == 0) + next + + # Get the length, format and the units strings. + nelems = pt_kstati (key, Memc[kname], KY_NUMELEMS) + len = pt_kstati (key, Memc[kname], KY_LENGTH) + call pt_kstats (key, Memc[kname], KY_UNITSTR, Memc[uname], + KY_SZPAR) + call pt_kstats (key, Memc[kname], KY_FMTSTR, Memc[fname], + KY_SZPAR) + + # Load the fields. + if (nelems == 1) { + + Memi[KY_SELECT(key)+nkeys] = index + Memi[KY_ELEM_SELECT(key)+nkeys] = 1 + Memi[KY_LEN_SELECT(key)+nkeys] = len + + call sprintf (Memc[nop], len, "%*.*s") + call pargi (-len) + call pargi (len) + call pargstr (Memc[kname]) + nop = nop + len + + call sprintf (Memc[uop], len, "%*.*s") + call pargi (-len) + call pargi (len) + call pargstr (Memc[uname]) + uop = uop + len + + call sprintf (Memc[fop], len, "%*.*s") + call pargi (-len) + call pargi (len) + call pargstr (Memc[fname]) + fop = fop + len + + nkeys = nkeys + 1 + + } else { + + if (Memc[ranges] == EOS) { + call sprintf (Memc[ranges], SZ_FNAME, "1-%d") + call pargi (nelems) + } + if (decode_ranges (Memc[ranges], Memi[rangeset], KY_MAXNRANGES, + elems) == ERR) + call error (0, "Cannot decode ranges string") + + elems = 0 + while (get_next_number (Memi[rangeset], elems) != EOF) { + + if (elems < 1 || elems > nelems) + break + Memi[KY_SELECT(key)+nkeys] = index + Memi[KY_ELEM_SELECT(key)+nkeys] = elems + Memi[KY_LEN_SELECT(key)+nkeys] = len + + call sprintf (Memc[nop], max_nkeys * KY_SZPAR, "%s%*.*d") + call pargstr (Memc[kname]) + call pargi (-len) + call pargi (len) + call pargi (elems) + nop = nop + len + + call sprintf (Memc[uop], len, "%*.*s") + call pargi (-len) + call pargi (len) + call pargstr (Memc[uname]) + uop = uop + len + + call sprintf (Memc[fop], len, "%*.*s") + call pargi (-len) + call pargi (len) + call pargstr (Memc[fname]) + fop = fop + len + + nkeys = nkeys + 1 + } + } + } + + # Reallocate the select buffer space. + KY_NSELECT(key) = nkeys + call realloc (KY_SELECT(key), KY_NSELECT(key), TY_INT) + call realloc (KY_ELEM_SELECT(key), KY_NSELECT(key), TY_INT) + call realloc (KY_LEN_SELECT(key), KY_NSELECT(key), TY_INT) + call realloc (KY_NAME_SELECT(key), KY_NSELECT(key) * KY_SZPAR, TY_CHAR) + call realloc (KY_UNIT_SELECT(key), KY_NSELECT(key) * KY_SZPAR, TY_CHAR) + call realloc (KY_FMT_SELECT(key), KY_NSELECT(key) * KY_SZPAR, TY_CHAR) + + # Free list storage space. + call pt_cfnl (list) + call sfree (sp) + + return (nkeys) +end diff --git a/noao/digiphot/lib/pttables/ptfmkrec.x b/noao/digiphot/lib/pttables/ptfmkrec.x new file mode 100644 index 00000000..3f7dcc84 --- /dev/null +++ b/noao/digiphot/lib/pttables/ptfmkrec.x @@ -0,0 +1,102 @@ +include "../ptkeysdef.h" + +# PT_FMKREC -- Construct the output record and mark the place of the +# requested field. + +int procedure pt_fmkrec (key, field, element, line, nchars, first_rec, + recptr, ncontinue) + +pointer key # pointer to record structure +int field # the index of the requested field +int element # the requested element of the field +char line[ARB] # input line +int nchars # length of line array +int first_rec # first record read +int recptr # line per record index +int ncontinue # number of unique lines per record + +int i, cip, nokeys, nckeys, nkeys, nper_line, len_move, offset +pointer op + +begin + # Initialize the offset. + offset = 0 + + # Reinitialize if this is the start of a new record. + if (recptr == 1) + nokeys = KY_NPKEYS(key) + + # Check repeat character. + if (line[nchars-2] == '*') + ncontinue = ncontinue + 1 + else + ncontinue = 0 + + # Fill in the record. + cip = 1 + if (ncontinue < 1) { + + nper_line = Memi[KY_NPLINE(key)+recptr-1] + nkeys = nokeys + nper_line + call amovki (int(1), Memi[KY_NELEMS(key)+nokeys], nper_line) + + len_move = 0 + do i = nokeys + 1, nkeys { + if (field == i) + offset = cip + len_move + len_move = len_move + Memi[KY_KINDICES(key)+i-1] + } + op = Memi[KY_PTRS(key)+nokeys] + call amovc (line[cip], Memc[op], len_move) + + cip = cip + len_move + recptr = recptr + 1 + nokeys = nkeys + + } else if (ncontinue == 1) { + + nckeys = nokeys + 1 + nkeys = nokeys + Memi[KY_NPLINE(key)+recptr-1] + + if (first_rec == YES) { + Memi[KY_NCONTINUE(key)+recptr-1] = KY_NLINES + do i = nckeys, nkeys + call malloc (Memi[KY_PTRS(key)+i-1], KY_NLINES * + Memi[KY_KINDICES(key)+i-1], TY_CHAR) + } + + do i = nckeys, nkeys { + if ((field == i) && (element == 1)) + offset = cip + call amovc (line[cip], Memc[Memi[KY_PTRS(key)+i-1]], + Memi[KY_KINDICES(key)+i-1]) + cip = cip + Memi[KY_KINDICES(key)+i-1] + } + + nokeys = nkeys + recptr = recptr + 1 + + } else { + + if (ncontinue > Memi[KY_NCONTINUE(key)+recptr-2]) { + Memi[KY_NCONTINUE(key)+recptr-2] = Memi[KY_NCONTINUE(key)+ + recptr-2] + KY_NLINES + do i = nckeys, nkeys + call realloc (Memi[KY_PTRS(key)+i-1], + Memi[KY_NCONTINUE(key)+recptr-2] * + Memi[KY_KINDICES(key)+i-1], TY_CHAR) + } + + do i = nckeys, nkeys { + op = Memi[KY_PTRS(key)+i-1] + (ncontinue - 1) * + Memi[KY_KINDICES(key)+i-1] + if ((field == i) && (element == ncontinue)) + offset = cip + call amovc (line[cip], Memc[op], Memi[KY_KINDICES(key)+i-1]) + Memi[KY_NELEMS(key)+i-1] = ncontinue + cip = cip + Memi[KY_KINDICES(key)+i-1] + } + } + + return (offset) +end diff --git a/noao/digiphot/lib/pttables/ptgetop.x b/noao/digiphot/lib/pttables/ptgetop.x new file mode 100644 index 00000000..c2697767 --- /dev/null +++ b/noao/digiphot/lib/pttables/ptgetop.x @@ -0,0 +1,112 @@ +include <evexpr.h> +include "../ptkeysdef.h" + +# PT_GETOP -- Procedure to fetch an apphot operand for evexpr. + +procedure pt_getop (operand, o) + +char operand[ARB] # operand name +pointer o # operand output + +pointer apkey +common /kycommon/ apkey +errchk pt_getfield() + +begin + call pt_getfield (apkey, operand, o) +end + + +# PT_APSET -- Porcedure to pass the apphot structure in a common block. + +procedure pt_apset (key) + +pointer key # apphot strucuture + +pointer apkey +common /kycommon/ apkey + +begin + apkey = key +end + + +# PT_GETFIELD -- Procedure to select an apphot field. + +procedure pt_getfield (key, field, o) + +pointer key # pointer to select strucuture +char field[ARB] # field to evaluated +pointer o # operand + +int type, maxnelems, nelems +pointer sp, root, ranges, list +bool pt_kybool() +int pt_kytype(), pt_kyinteger(), decode_ranges() +real pt_kyreal() +errchk pt_kytype(), pt_kybool(), pt_kyreal(), pt_kystr() + +begin + call smark (sp) + call salloc (root, SZ_FNAME, TY_CHAR) + call salloc (ranges, SZ_FNAME, TY_CHAR) + call salloc (list, 3 * KY_MAXNRANGES + 1, TY_INT) + + # Select the field. + call strupr (field) + type = pt_kytype (key, field, Memc[root], Memc[ranges], maxnelems) + if (Memc[ranges] == EOS) { + nelems = 1 + Memi[list] = 1 + } else if (decode_ranges (Memc[ranges], Memi[list], KY_MAXNRANGES, + nelems) == ERR) { + call sfree (sp) + call error (0, "Cannot decode range string") + } + + # Decode the value. + switch (type) { + case TY_BOOL: + if (nelems == 1) { + call xev_initop (o, 0, TY_BOOL) + O_VALB(o) = pt_kybool (key, Memc[root], Memi[list]) + } else { + call sfree (sp) + call eprintf ("Error decoding boolean field array: %s\n") + call pargstr (field) + call error (0, "Boolean arrays not allowed in expressions.") + } + case TY_INT: + if (nelems == 1) { + call xev_initop (o, 0, TY_INT) + O_VALI(o) = pt_kyinteger (key, Memc[root], Memi[list]) + } else { + call sfree (sp) + call eprintf ("Error decoding integer field array: %s\n") + call pargstr (field) + call error (0, "Integer arrays not allowed in expressions.") + } + case TY_REAL: + if (nelems == 1) { + call xev_initop (o, 0, TY_REAL) + O_VALR(o) = pt_kyreal (key, Memc[root], Memi[list]) + } else { + call sfree (sp) + call eprintf ("Error decoding real array field: %s\n") + call pargstr (field) + call error (0, "Real arrays not allowed in expressions.") + } + default: + if (nelems == 1) { + call xev_initop (o, SZ_LINE, TY_CHAR) + call pt_kystr (key, Memc[root], Memi[list], O_VALC(o), SZ_LINE) + } else { + call eprintf ("Error decoding char array field: %s\n") + call sfree (sp) + call pargstr (field) + call error (0, "Character arrays not allowed in expressions.") + } + } + + call sfree (sp) +end diff --git a/noao/digiphot/lib/pttables/ptgnfn.x b/noao/digiphot/lib/pttables/ptgnfn.x new file mode 100644 index 00000000..f3d4ddcb --- /dev/null +++ b/noao/digiphot/lib/pttables/ptgnfn.x @@ -0,0 +1,239 @@ +include <syserr.h> +include <ctype.h> +include "../ptkeysdef.h" + +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 +define FN_STRP Memi[$1+10+$2-1] # array of str ptrs + +define FN_FIELDNAME Memc[FN_STRP($1,$2)] # reference a string + + +# PT_OFNL -- Procedure to decode the template. + +pointer procedure pt_ofnl (ap, template) + +pointer ap # image descriptor +char template[ARB] # field name template + +int tp, nstr, ch, junk +pointer sp, ip, op, rop, fn, pattern, patcode, ranges, nextch +int patmake(), patmatch() +errchk syserr + +begin + call smark (sp) + call salloc (pattern, SZ_FNAME, TY_CHAR) + call salloc (patcode, SZ_LINE, TY_CHAR) + call salloc (ranges, SZ_FNAME, TY_CHAR) + + # Allocate field list descriptor and initialize. + call calloc (fn, LEN_FNSTRUCT, TY_STRUCT) + call malloc (FN_SBUF(fn), SZ_SBUF, TY_CHAR) + nextch = FN_SBUF(fn) + nstr = 0 + tp = 1 + + # Extract each comma delimited template, expand upon the aphot + # database 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 + # be case insensitive. + + op = pattern + Memc[op] = '^' + op = op + 1 + Memc[op] = '{' + op = op + 1 + + # Fetch the pattern. + ch = template[tp] + while (! (IS_WHITE(ch) || ch == '\n' || ch == ',' || ch == '[' || + ch == EOS)) { + + # Map "*" into "?*". + if (ch == '*') { + Memc[op] = '?' + op = op + 1 + } + + # Update. + Memc[op] = ch + op = op + 1 + tp = tp + 1 + ch = template[tp] + } + + # Decode ranges. + if (ch == '[') { + rop = ranges + while (! (ch == '\n' || ch == EOS || ch == ']')) { + Memc[rop] = ch + rop = rop + 1 + tp = tp + 1 + ch = template[tp] + } + Memc[rop] = ']' + rop = rop + 1 + tp = tp + 1 + ch = template[tp] + while (ch != EOS && ch != '\n' && ch != ',' && IS_DIGIT(ch)) { + Memc[rop] = ch + tp = tp + 1 + ch = template[tp] + rop = rop + 1 + } + Memc[rop] = EOS + } else + Memc[ranges] = EOS + + # Close off the pattern. + Memc[op] = '}' + op = op + 1 + Memc[op] = EOS + + # Encode the pattern. + junk = patmake (Memc[pattern], Memc[patcode], SZ_LINE) + + # Scan database and extract all field names matching the + # pattern. + + for (ip = KY_WORDS(ap) + 1; Memc[ip] != EOS; ip = ip + 1) { + + # Put key in list if it matches. + if (patmatch (Memc[ip], Memc[patcode]) > 0) { + call pt_fnputkey (Memc[ip], Memc[ranges], FN_STRP(fn,1), + nstr, nextch, FN_SBUF(fn)) + } + + # Advance to the next record. + while (Memc[ip] != ',' && Memc[ip] != EOS) + ip = ip + 1 + + # Quit if you hit EOS + if (Memc[ip] == EOS) + break + } + } + + FN_NENTRIES(fn) = nstr + FN_NEXT(fn) = 1 + call sfree (sp) + return (fn) +end + + +# PT_GNFN -- Get the next field name matching the given template from the +# apphot data base. + +int procedure pt_gnfn (fn, outstr, ranges, maxch) + +pointer fn # field name list descriptor +char outstr[ARB] # output string +char ranges[ARB] # ranges string +int maxch # maximum number of characters + +char left_bkt +int strnum, findex, nchars +int gstrcpy(), stridx() +data left_bkt /'['/ + +begin + # Initialize. + ranges[1] = EOS + outstr[1] = EOS + + # Check that there is an entry + strnum = FN_NEXT(fn) + if (strnum > FN_NENTRIES(fn)) + return (EOF) + + # Get the next field name. + nchars = gstrcpy (FN_FIELDNAME(fn,strnum), outstr, maxch) + + # Get the ranges string. + findex = stridx (left_bkt, outstr) + if (findex > 0) { + call strcpy (outstr[findex], ranges, maxch) + outstr[findex] = EOS + } + + # Increment counter. + FN_NEXT(fn) = strnum + 1 + + return (nchars) +end + + +# PT_CFNL -- Procedure to close the list. + +procedure pt_cfnl (fn) + +pointer fn # field name list descriptor + +begin + call mfree (FN_SBUF(fn), TY_CHAR) + call mfree (fn, TY_STRUCT) +end + + + +# PT_FNPUTKEY -- Put a keyword into the keyword list. + +procedure pt_fnputkey (key, ranges, strp, nstr, nextch, sbuf) + +char key[ARB] # keyword name (etc.) +char ranges[ARB] # list of ranges +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, rip +errchk syserr + +begin + # Check size of string buffer. + nstr = nstr + 1 + if (nstr > MAX_FIELDS) + call error (0, "There too many fields in the input template") + + # Initialize. + strp[nstr] = nextch + ip = 1 + ch = key[ip] + + # Append keyword to the string buffer. + while (ch != ',' && ch != ' ' && ch != EOS) { + Memc[nextch] = ch + nextch = nextch + 1 + if (nextch >= sbuf + SZ_SBUF) + call error (0, "There too many fields in the input template") + ip = ip + 1 + ch = key[ip] + } + + # Get the ranges information. + rip = 1 + while (ranges[rip] != EOS) { + Memc[nextch] = ranges[rip] + nextch = nextch + 1 + if (nextch >= sbuf + SZ_SBUF) + call error (0, "There too many fields in the input template") + rip = rip + 1 + } + + Memc[nextch] = EOS + nextch = nextch + 1 +end diff --git a/noao/digiphot/lib/pttables/pthdrs.x b/noao/digiphot/lib/pttables/pthdrs.x new file mode 100644 index 00000000..d3aeecf6 --- /dev/null +++ b/noao/digiphot/lib/pttables/pthdrs.x @@ -0,0 +1,235 @@ +include "../ptkeysdef.h" + +# PT_KNAME -- Procedure to add a name to the keyword structure + +procedure pt_kname (key, line, nchars, nunique) + +pointer key # pointer to keyword structure +char line[ARB] # line to be decoded +int nchars # number of characters in the line +int nunique # number of #N lines + +int nkeys, onstore +long optr +pointer sp, id, keyword, temp +int nscan(), strdic() + +begin + # Store the old number of keywords and the old values pointer. + onstore = KY_NSTORE(key) + optr = KY_VALUES(key) + + # Check the buffer sizes. + if ((KY_NKEYS(key) + 1) > KY_NSTORE(key)) { + KY_NSTORE(key) = KY_NSTORE(key) + KY_NPARS + call realloc (KY_WORDS(key), KY_NSTORE(key) * KY_SZPAR, TY_CHAR) + call realloc (KY_VALUES(key), KY_NSTORE(key) * KY_SZPAR, TY_CHAR) + call realloc (KY_UNITS(key), KY_NSTORE(key) * KY_SZPAR, TY_CHAR) + call realloc (KY_FORMATS(key), KY_NSTORE(key) * KY_SZPAR, TY_CHAR) + call realloc (KY_TYPES(key), KY_NSTORE(key), TY_INT) + call realloc (KY_KINDICES(key), KY_NSTORE(key), TY_INT) + call realloc (KY_UINDICES(key), KY_NSTORE(key), TY_INT) + call realloc (KY_FINDICES(key), KY_NSTORE(key) + 1, TY_INT) + call realloc (KY_NELEMS(key), KY_NSTORE(key), TY_INT) + call aclri (Memi[KY_NELEMS(key)+onstore], KY_NSTORE(key) - onstore) + #lshift = KY_VALUES(key) - optr + call realloc (KY_PTRS(key), KY_NSTORE(key), TY_INT) + call aaddki (Memi[KY_PTRS(key)], KY_VALUES(key)- optr, + Memi[KY_PTRS(key)], onstore) + call amovki (NULL, Memi[KY_PTRS(key)+onstore], KY_NSTORE(key) - + onstore) + } + + # Check the available space. + if (nunique > KY_NLINES) { + call realloc (KY_NPLINE(key), nunique, TY_INT) + call realloc (KY_NCONTINUE(key), nunique, TY_INT) + } + + # Allocate space for the keywords. + call smark (sp) + call salloc (id, KY_SZPAR, TY_CHAR) + call salloc (keyword, KY_SZPAR, TY_CHAR) + call salloc (temp, KY_SZPAR, TY_CHAR) + + # Scan the string and remove the id. + call sscan (line) + call gargwrd (Memc[id], KY_SZPAR) + if (nscan() != 1) { + call sfree (sp) + return + } + + # Loop over the keywords. + nkeys = 0 + call gargwrd (Memc[keyword], KY_SZPAR) + while (Memc[keyword] != EOS && Memc[keyword] != '\\') { + if (strdic (Memc[keyword], Memc[temp], KY_SZPAR, + Memc[KY_WORDS(key)]) == 0) { + nkeys = nkeys + 1 + call pt_kykeywrd (Memc[keyword], KY_SZPAR, LEN_KWORDS(key), + Memc[KY_WORDS(key)]) + } + call gargwrd (Memc[keyword], KY_SZPAR) + } + + # Update. + #if (nunique == 1) + #KY_NOKEYS(key) = KY_NKEYS(key) + Memi[KY_NPLINE(key)+nunique-1] = nkeys + Memi[KY_NCONTINUE(key)+nunique-1] = 0 + KY_NKEYS(key) = KY_NKEYS(key) + nkeys + + call sfree (sp) +end + + +# PT_KNUNITS -- Procedure to add a unit name to the keyword structure. + +procedure pt_knunits (key, line, nchars, uunique) + +pointer key # pointer to keyword structure +char line[ARB] # line to be decoded +int nchars # number of characters in the line +int uunique # number of #U lines + +int nkeys, onstore +long optr +pointer sp, id, units, temp +int nscan() + +begin + # If there are no unique names for this line quit. + if (Memi[KY_NPLINE(key)+uunique-1] <= 0) + return + + # Store old number of keywords and old values pointer. + onstore = KY_NSTORE(key) + optr = KY_VALUES(key) + + # Check the buffer sizes. + if ((KY_NKEYS(key) + 1) > KY_NSTORE(key)) { + KY_NSTORE(key) = KY_NSTORE(key) + KY_NPARS + call realloc (KY_WORDS(key), KY_NSTORE(key) * KY_SZPAR, TY_CHAR) + call realloc (KY_VALUES(key), KY_NSTORE(key) * KY_SZPAR, TY_CHAR) + call realloc (KY_UNITS(key), KY_NSTORE(key) * KY_SZPAR, TY_CHAR) + call realloc (KY_FORMATS(key), KY_NSTORE(key) * KY_SZPAR, TY_CHAR) + call realloc (KY_TYPES(key), KY_NSTORE(key), TY_INT) + call realloc (KY_KINDICES(key), KY_NSTORE(key), TY_INT) + call realloc (KY_UINDICES(key), KY_NSTORE(key), TY_INT) + call realloc (KY_FINDICES(key), KY_NSTORE(key) + 1, TY_INT) + call realloc (KY_NELEMS(key), KY_NSTORE(key), TY_INT) + call aclri (Memi[KY_NELEMS(key)+onstore], KY_NSTORE(key) - onstore) + #lshift = KY_VALUES(key) - optr + call realloc (KY_PTRS(key), KY_NSTORE(key), TY_INT) + call aaddki (Memi[KY_PTRS(key)], KY_VALUES(key) - optr, + Memi[KY_PTRS(key)], onstore) + call amovki (NULL, Memi[KY_PTRS(key)+onstore], KY_NSTORE(key) - + onstore) + } + + # Allocate space for the units. + call smark (sp) + call salloc (id, KY_SZPAR, TY_CHAR) + call salloc (units, KY_SZPAR, TY_CHAR) + call salloc (temp, KY_SZPAR, TY_CHAR) + + # Scan the string and decode the elements. + call sscan (line) + call gargwrd (Memc[id], KY_SZPAR) + + # Remove the id. + if (nscan() != 1) { + call sfree (sp) + return + } + + # Loop over the units string. + if (uunique == 1) + nkeys = KY_NPKEYS(key) + call gargwrd (Memc[units], KY_SZPAR) + while (Memc[units] != EOS && Memc[units] != '\\') { + call pt_kyunits (Memc[units], KY_SZPAR, Memc[KY_UNITS(key)], + Memi[KY_UINDICES(key)], nkeys + 1) + nkeys = nkeys + 1 + call gargwrd (Memc[units], KY_SZPAR) + } + + call sfree (sp) +end + + +# PT_KNFORMATS -- Procedure to add a format to the keyword structure. + +procedure pt_knformats (key, line, nchars, funique) + +pointer key # pointer to keyword structure +char line[ARB] # line to be decoded +int nchars # number of characters in the line +int funique # number of format lines + +int nkeys, onstore +long optr +pointer sp, id, format, temp +int nscan() + +begin + # If there are no unique names for this line quit. + if (Memi[KY_NPLINE(key)+funique-1] <= 0) + return + + # Store the old number of keywords and the old values pointer. + onstore = KY_NSTORE(key) + optr = KY_VALUES(key) + + # Check the buffer sizes. + if ((KY_NKEYS(key) + 1) > KY_NSTORE(key)) { + KY_NSTORE(key) = KY_NSTORE(key) + KY_NPARS + call realloc (KY_WORDS(key), KY_NSTORE(key) * KY_SZPAR, TY_CHAR) + call realloc (KY_VALUES(key), KY_NSTORE(key) * KY_SZPAR, TY_CHAR) + call realloc (KY_UNITS(key), KY_NSTORE(key) * KY_SZPAR, TY_CHAR) + call realloc (KY_FORMATS(key), KY_NSTORE(key) * KY_SZPAR, TY_CHAR) + call realloc (KY_TYPES(key), KY_NSTORE(key), TY_INT) + call realloc (KY_KINDICES(key), KY_NSTORE(key), TY_INT) + call realloc (KY_UINDICES(key), KY_NSTORE(key), TY_INT) + call realloc (KY_FINDICES(key), KY_NSTORE(key) + 1, TY_INT) + call realloc (KY_NELEMS(key), KY_NSTORE(key), TY_INT) + call aclri (Memi[KY_NELEMS(key)+onstore], KY_NSTORE(key) - onstore) + #lshift = KY_VALUES(key) - optr + call realloc (KY_PTRS(key), KY_NSTORE(key), TY_INT) + call aaddki (Memi[KY_PTRS(key)], KY_VALUES(key) - optr, + Memi[KY_PTRS(key)], onstore) + call amovki (NULL, Memi[KY_PTRS(key)+onstore], KY_NSTORE(key) - + onstore) + } + + # Allocate space for the keywords. + call smark (sp) + call salloc (id, KY_SZPAR, TY_CHAR) + call salloc (format, KY_SZPAR, TY_CHAR) + call salloc (temp, KY_SZPAR, TY_CHAR) + + # Scan the string and decode the elements. + call sscan (line) + call gargwrd (Memc[id], KY_SZPAR) + + # Remove the id. + if (nscan() != 1) { + call sfree (sp) + return + } + + # Loop over the formats. + if (funique == 1) + nkeys = KY_NPKEYS(key) + call gargwrd (Memc[format], KY_SZPAR) + while (Memc[format] != EOS && Memc[format] != '\\') { + call pt_kyformat (Memc[format], KY_SZPAR, Memc[KY_FORMATS(key)], + Memi[KY_FINDICES(key)], Memi[KY_TYPES(key)], Memi[KY_PTRS(key)], + Memi[KY_KINDICES(key)], nkeys + 1) + nkeys = nkeys + 1 + call gargwrd (Memc[format], KY_SZPAR) + } + + call sfree (sp) +end diff --git a/noao/digiphot/lib/pttables/ptkeywords.x b/noao/digiphot/lib/pttables/ptkeywords.x new file mode 100644 index 00000000..c636b8fd --- /dev/null +++ b/noao/digiphot/lib/pttables/ptkeywords.x @@ -0,0 +1,615 @@ +include "../ptkeysdef.h" + +# PT_KYINIT -- Initilize the keyword structure. + +procedure pt_kyinit (key) + +pointer key # pointer to the keys structure + +begin + # Allocate space for structure and initialize constants. + call malloc (key, LEN_KEYSTRUCT, TY_STRUCT) + KY_NKEYS(key) = 0 + KY_NPKEYS(key) = 0 + KY_NSTORE(key) = KY_NPARS + LEN_KWORDS(key) = 0 + + # Allocate space for the string buffers. + call malloc (KY_WORDS(key), KY_SZPAR * KY_NPARS, TY_CHAR) + call malloc (KY_VALUES(key), KY_SZPAR * KY_NPARS, TY_CHAR) + call malloc (KY_UNITS(key), KY_SZPAR * KY_NPARS, TY_CHAR) + call malloc (KY_FORMATS(key), KY_SZPAR * KY_NPARS, TY_CHAR) + + # Allocate space for the indices buffers and initialize. + call malloc (KY_PTRS(key), KY_NPARS, TY_INT) + call malloc (KY_KINDICES(key), KY_NPARS, TY_INT) + call malloc (KY_UINDICES(key), KY_NPARS, TY_INT) + call malloc (KY_FINDICES(key), KY_NPARS + 1, TY_INT) + call calloc (KY_NELEMS(key), KY_NPARS, TY_INT) + call malloc (KY_TYPES(key), KY_NPARS, TY_INT) + call calloc (KY_NPLINE(key), KY_NLINES, TY_INT) + call calloc (KY_NCONTINUE(key), KY_NLINES, TY_INT) + Memi[KY_PTRS(key)] = KY_VALUES(key) + call amovki (NULL, Memi[KY_PTRS(key)+1], KY_NPARS - 1) + + # Initialize the select buffers. + KY_SELECT(key) = NULL + KY_ELEM_SELECT(key) = NULL + KY_LEN_SELECT(key) = NULL + KY_NAME_SELECT(key) = NULL + KY_UNIT_SELECT(key) = NULL + KY_FMT_SELECT(key) = NULL + + # Initilize the strings. + Memc[KY_WORDS(key)] = EOS + Memc[KY_VALUES(key)] = EOS + Memc[KY_UNITS(key)] = EOS + Memc[KY_FORMATS(key)] = EOS +end + + +# PT_KYFREE -- Procedure to free the keywords structure. + +procedure pt_kyfree (key) + +pointer key # pointer to keyword structure + +int i +pointer ptr + +begin + # Free the string buffers. + if (KY_WORDS(key) != NULL) + call mfree (KY_WORDS(key), TY_CHAR) + if (KY_VALUES(key) != NULL) + call mfree (KY_VALUES(key), TY_CHAR) + if (KY_UNITS(key) != NULL) + call mfree (KY_UNITS(key), TY_CHAR) + if (KY_FORMATS(key) != NULL) + call mfree (KY_FORMATS(key), TY_CHAR) + + # Free the indices buffers. + if (KY_TYPES(key) != NULL) + call mfree (KY_TYPES(key), TY_INT) + if (KY_KINDICES(key) != NULL) + call mfree (KY_KINDICES(key), TY_INT) + if (KY_UINDICES(key) != NULL) + call mfree (KY_UINDICES(key), TY_INT) + if (KY_FINDICES(key) != NULL) + call mfree (KY_FINDICES(key), TY_INT) + if (KY_PTRS(key) != NULL) { + do i = 1, KY_NSTORE(key) { + ptr = Memi[KY_PTRS(key)+i-1] + if (ptr != NULL && Memi[KY_NELEMS(key)+i-1] > 1) + call mfree (ptr, TY_CHAR) + } + call mfree (KY_PTRS(key), TY_INT) + } + if (KY_NELEMS(key) != NULL) + call mfree (KY_NELEMS(key), TY_INT) + if (KY_NPLINE(key) != NULL) + call mfree (KY_NPLINE(key), TY_INT) + if (KY_NCONTINUE(key) != NULL) + call mfree (KY_NCONTINUE(key), TY_INT) + + # Free the select buffers. + if (KY_SELECT(key) != NULL) + call mfree (KY_SELECT(key), TY_INT) + if (KY_ELEM_SELECT(key) != NULL) + call mfree (KY_ELEM_SELECT(key), TY_INT) + if (KY_LEN_SELECT(key) != NULL) + call mfree (KY_LEN_SELECT(key), TY_INT) + if (KY_NAME_SELECT(key) != NULL) + call mfree (KY_NAME_SELECT(key), TY_CHAR) + if (KY_UNIT_SELECT(key) != NULL) + call mfree (KY_UNIT_SELECT(key), TY_CHAR) + if (KY_FMT_SELECT(key) != NULL) + call mfree (KY_FMT_SELECT(key), TY_CHAR) + + call mfree (key, TY_STRUCT) +end + + +# PT_KYADD -- Procedure to add a parameter to the keyword structure. + +procedure pt_kyadd (key, line, nchars) + +pointer key # pointer to keyword structure +char line[ARB] # line to be decoded +int nchars # number of characters in the line + +int index, onstore +long optr +pointer sp, id, keyword, equals, value, units, format, temp +int nscan(), strdic() + +begin + # Check the buffer sizes. + onstore = KY_NSTORE(key) + optr = KY_VALUES(key) + if ((KY_NKEYS(key) + 1) > KY_NSTORE(key)) { + KY_NSTORE(key) = KY_NSTORE(key) + KY_NPARS + call realloc (KY_WORDS(key), KY_NSTORE(key) * KY_SZPAR, TY_CHAR) + call realloc (KY_VALUES(key), KY_NSTORE(key) * KY_SZPAR, TY_CHAR) + call realloc (KY_UNITS(key), KY_NSTORE(key) * KY_SZPAR, TY_CHAR) + call realloc (KY_FORMATS(key), KY_NSTORE(key) * KY_SZPAR, TY_CHAR) + call realloc (KY_NELEMS(key), KY_NSTORE(key), TY_INT) + call aclri (Memi[KY_NELEMS(key)+onstore], KY_NSTORE(key) - onstore) + call realloc (KY_PTRS(key), KY_NSTORE(key), TY_INT) + call aaddki (Memi[KY_PTRS(key)], KY_VALUES(key) - optr, + Memi[KY_PTRS(key)], onstore) + call amovki (NULL, Memi[KY_PTRS(key)+onstore], KY_NSTORE(key) - + onstore) + call realloc (KY_TYPES(key), KY_NSTORE(key), TY_INT) + call realloc (KY_KINDICES(key), KY_NSTORE(key), TY_INT) + call realloc (KY_UINDICES(key), KY_NSTORE(key), TY_INT) + call realloc (KY_FINDICES(key), KY_NSTORE(key) + 1, TY_INT) + } + + # Allocate space for the keywords. + call smark (sp) + call salloc (id, KY_SZPAR, TY_CHAR) + call salloc (keyword, KY_SZPAR, TY_CHAR) + call salloc (equals, KY_SZPAR, TY_CHAR) + call salloc (value, KY_SZPAR, TY_CHAR) + call salloc (units, KY_SZPAR, TY_CHAR) + call salloc (format, KY_SZPAR, TY_CHAR) + call salloc (temp, KY_SZPAR, TY_CHAR) + + # Scan the string and decode the elements. + call sscan (line) + call gargwrd (Memc[id], KY_SZPAR) + call gargwrd (Memc[keyword], KY_SZPAR) + call gargwrd (Memc[equals], KY_SZPAR) + call gargwrd (Memc[value], KY_SZPAR) + call gargwrd (Memc[units], KY_SZPAR) + call gargwrd (Memc[format], KY_SZPAR) + + # Return if insufficient number of elements. + if (nscan() < 6) { + call sfree (sp) + return + } + + # Add the parameters. + index = strdic (Memc[keyword], Memc[temp], KY_SZPAR, + Memc[KY_WORDS(key)]) + if (index == 0) { + KY_NPKEYS(key) = KY_NPKEYS(key) + 1 + KY_NKEYS(key) = KY_NKEYS(key) + 1 + Memi[KY_NELEMS(key)+KY_NKEYS(key)-1] = 1 + call pt_kykeywrd (Memc[keyword], KY_SZPAR, LEN_KWORDS(key), + Memc[KY_WORDS(key)]) + call pt_kyunits (Memc[units], KY_SZPAR, Memc[KY_UNITS(key)], + Memi[KY_UINDICES(key)], KY_NKEYS(key)) + call pt_kyformat (Memc[format], KY_SZPAR, Memc[KY_FORMATS(key)], + Memi[KY_FINDICES(key)], Memi[KY_TYPES(key)], Memi[KY_PTRS(key)], + Memi[KY_KINDICES(key)], KY_NKEYS(key)) + call pt_kyvalue (Memc[value], KY_SZPAR, Memc[KY_VALUES(key)], + Memi[KY_PTRS(key)], Memi[KY_KINDICES(key)], KY_NKEYS(key)) + } else + call pt_kyaddval (Memc[value], KY_SZPAR, Memc[KY_VALUES(key)], + Memi[KY_PTRS(key)], Memi[KY_KINDICES(key)], index) + + call sfree (sp) +end + + +# PT_KYKEYWRD -- Procedure to encode a single keyword into the keyword +# dictionary. + +procedure pt_kykeywrd (keyword, maxch, klength, kdic) + +char keyword[ARB] # the keyword to be added to the list +int maxch # maximum length of keyword +int klength # the current length of the dictionary +char kdic[ARB] # the keyword dictionary + +int kp, ip + +begin + # Insert leading , for record delimiter. + kp = klength + 1 + if (kp == 1) { + kdic[kp] = ',' + kp = kp + 1 + } + + # Copy the keyword. + for (ip = 1; ip <= maxch && keyword[ip] != EOS; ip = ip + 1) { + kdic[kp] = keyword[ip] + kp = kp + 1 + } + kdic[kp] = ',' + kdic[kp+1] = EOS + + klength = kp +end + + +# PT_KYUNITS -- Procedure to add a units name to the units string. + +procedure pt_kyunits (ustr, maxch, units, uindices, nkey) + +char ustr[ARB] # units string +int maxch # max length of units string +char units[ARB] # units string +int uindices[ARB] # units indices +int nkey # current unit + +int ip, up + +begin + # Get initial position. + if (nkey == 1) + up = 1 + else + up = uindices[nkey-1] + 1 + + # Copy the units string. + for (ip = 1; ip <= maxch && ustr[ip] != EOS; ip = ip + 1) { + units[up] = ustr[ip] + up = up + 1 + } + units[up] = EOS + + uindices[nkey] = up - 1 +end + + +# PT_KYFORMAT -- Procedure to encode the formats and field widths. + +procedure pt_kyformat (fstr, maxch, formats, findices, types, ptrs, fields, + key) + +char fstr[ARB] # format string +int maxch # maximum number of characters +char formats[ARB] # format string +int findices[ARB] # string pointers +int types[ARB] # data type of key +pointer ptrs[ARB] # array of pointers +int fields[ARB] # integer field widths +int key # key number + +char cjunk +int ip, fp, fwidth, junk, ftype +int pt_kyfstr(), strlen() + +begin + # Set the pointer. + if (key > 1) + ptrs[key] = ptrs[key-1] + fields[key-1] + + # Find the initial position. + if (key == 1) + fp = 1 + else + fp = findices[key-1] + 1 + + # Crack the format string. + if (pt_kyfstr (fstr, fwidth, junk, ftype, cjunk) == ERR) { + fields[key] = KY_SZPAR + types[key] = TY_CHAR + #if (key > 1) + #ptrs[key] = ptrs[key-1] + fwidth + call sprintf (formats[fp], maxch, "%s%ds") + call pargstr ("%") + call pargi (-KY_SZPAR) + fp = fp + strlen (formats[fp]) + } else { + fields[key] = fwidth + types[key] = ftype + #if (key > 1) + #ptrs[key] = ptrs[key-1] + fields[key-1] + for (ip = 1; ip <= maxch && fstr[ip] != EOS; ip = ip + 1) { + formats[fp] = fstr[ip] + fp = fp + 1 + } + formats[fp] = EOS + } + + findices[key] = fp - 1 +end + + +# PT_KYVALUE -- Procedure to store the parameter value. + +procedure pt_kyvalue (vstr, maxch, values, ptrs, kindices, key) + +char vstr[ARB] # value string +int maxch # maximum number of characters +char values[ARB] # values string +pointer ptrs[ARB] # array of pointers +int kindices[ARB] # storage points in the string +int key # parameter + +int ip, vp + +begin + # Find the initial position. + if (key == 1) + vp = 1 + else + vp = ptrs[key] - ptrs[1] + 1 + + # Copy the value string. + for (ip = 1; ip <= maxch && vstr[ip] != EOS; ip = ip + 1) { + values[vp] = vstr[ip] + vp = vp + 1 + } + for (; ip <= kindices[key]; ip = ip + 1) { + values[vp] = ' ' + vp = vp + 1 + } + values[vp] = EOS +end + + +# PT_KYADDVAL -- Change the value of an existing keyword. + +procedure pt_kyaddval (vstr, maxch, values, ptrs, kindices, key) + +char vstr[ARB] # value string +int maxch # maximum number of characters +char values[ARB] # values string +pointer ptrs[ARB] # array of pointers +int kindices[ARB] # storage points in the string +int key # parameter + +int ip, vp + +begin + # Find the initial position. + if (key == 1) + vp = 1 + else + vp = ptrs[key] - ptrs[1] + 1 + + # Insert the new value. + for (ip = 1; ip <= maxch && vstr[ip] != EOS; ip = ip + 1) { + values[vp] = vstr[ip] + vp = vp + 1 + } + for (; ip <= kindices[key]; ip = ip + 1) { + values[vp] = ' ' + vp = vp + 1 + } +end + + +# PT_KYFSTR -- Procedure to decode the format string. + +int procedure pt_kyfstr (fstr, width, precision, type, ctype) + +char fstr[ARB] # format string +int width # field width +int precision # precision +int type # data type +char ctype # char format type + +int ip +int ctoi + +begin + if (fstr[1] != '%') + return (ERR) + + # Get the field width. + ip = 2 + if (ctoi (fstr, ip, width) == ERR) + return (ERR) + width = abs (width) + + # Get the precision. + if (fstr[ip] == '.') + ip = ip + 1 + if (ctoi (fstr, ip, precision) == ERR) + precision = 0 + + # Get the datatype. + if (fstr[ip] == 'f' || fstr[ip] == 'g') { + type = TY_REAL + ctype = fstr[ip] + } else if (fstr[ip] == 'd') { + type = TY_INT + ctype = 'd' + } else if (fstr[ip] == 's') { + type = TY_CHAR + ctype = 's' + } else if (fstr[ip] == 'b') { + type = TY_BOOL + ctype = 'b' + } else + return (ERR) + return (OK) +end + + +# PT_KYTYPE -- Procedure to get the data type of a field. + +int procedure pt_kytype (key, field, root, ranges, maxels) + +pointer key # pointer to field strucuture +char field[ARB] # field for which type is to be extracted +char root[ARB] # root variable name +char ranges[ARB] # range of selected elements +int maxels # maximum number of elements + +char left_bkt, right_bkt +int findex, lindex, index +pointer sp, temp +int stridx(), strdic() +data left_bkt /'['/, right_bkt /']'/ + +begin + # Allocate working space. + call smark (sp) + call salloc (temp, SZ_FNAME, TY_CHAR) + root[1] = EOS + ranges[1] = EOS + + # Get the root name. + findex = stridx (left_bkt, field) + if (findex == 0) + call strcpy (field, root, SZ_FNAME) + else + call strcpy (field, root, findex - 1) + + # Find the appropriate keyword. + index = strdic (root, Memc[temp], SZ_LINE, Memc[KY_WORDS(key)]) + call sfree (sp) + + # Return the root, ranges and type. + if (index != 0) { + maxels = Memi[KY_NELEMS(key)+index-1] + lindex = stridx (right_bkt, field) + if ((lindex - findex - 1) > 0) + call strcpy (field[findex+1], ranges, lindex - findex - 1) + if (ranges[1] == EOS && maxels > 1) + call sprintf (ranges, SZ_FNAME, "1-%d") + call pargi (maxels) + return (Memi[KY_TYPES(key)+index-1]) + } else + call error (0, "Unknown keyword in expression") +end + + +# PT_KYBOOL -- Procedure to get a boolean parameter. + +bool procedure pt_kybool (key, field, element) + +pointer key # pointer to keys structure +char field[ARB] # parameter name +int element # element of int array + +int index +pointer sp, temp, ptr +int strmatch() +pointer strdic() + +begin + call smark (sp) + call salloc (temp, SZ_LINE, TY_CHAR) + index = strdic (field, Memc[temp], SZ_LINE, Memc[KY_WORDS(key)]) + call sfree (sp) + + if (index != 0) { + if (Memi[KY_NELEMS(key)+index-1] == 1) + ptr = Memi[KY_PTRS(key)+index-1] + else + ptr = Memi[KY_PTRS(key)+index-1] + (element - 1) * + Memi[KY_KINDICES(key)+index-1] + if (strmatch (Memc[ptr], "yes") == 0) + return (false) + else + return (true) + } else + call error (0, "Unknown boolean keyword in expression") +end + + +# PT_KYINTEGER -- Procedure to get an integer parameter. + +int procedure pt_kyinteger (key, field, element) + +pointer key # pointer to keys structure +char field[ARB] # parameter name +int element # element of int array + +int index, ip, ival +pointer sp, temp, ptr +int ctoi() +pointer strdic() + +begin + call smark (sp) + call salloc (temp, SZ_LINE, TY_CHAR) + index = strdic (field, Memc[temp], SZ_LINE, Memc[KY_WORDS(key)]) + call sfree (sp) + + if (index != 0) { + if (Memi[KY_NELEMS(key)+index-1] == 1) + ptr = Memi[KY_PTRS(key)+index-1] + else + ptr = Memi[KY_PTRS(key)+index-1] + (element - 1) * + Memi[KY_KINDICES(key)+index-1] + ip = 1 + if (ctoi (Memc[ptr], ip, ival) == 0) + call error (0, "Cannot decode integer parameter") + else + return (ival) + } else + call error (0, "Unknown integer keyword in expression") +end + + +# PT_KYREAL -- Procedure to get a real parameter. + +real procedure pt_kyreal (key, field, element) + +pointer key # pointer to keys structure +char field[ARB] # parameter name +int element # which element to extract + +int index, ip +pointer sp, temp, ptr +real rval +int ctor() +pointer strdic() + +begin + call smark (sp) + call salloc (temp, SZ_LINE, TY_CHAR) + index = strdic (field, Memc[temp], SZ_LINE, Memc[KY_WORDS(key)]) + call sfree (sp) + + if (index != 0) { + if (Memi[KY_NELEMS(key)+index-1] == 1) + ptr = Memi[KY_PTRS(key)+index-1] + else + ptr = Memi[KY_PTRS(key)+index-1] + (element - 1) * + Memi[KY_KINDICES(key)+index-1] + ip = 1 + if (ctor (Memc[ptr], ip, rval) <= 0) + call error (0, "Cannot decode real parameter") + else + return (rval) + } else + call error (0, "Unknown real keyword in expression") +end + + +# PT_KYSTR -- Procedure to get a string parameter. + +procedure pt_kystr (key, field, element, str, maxch) + +pointer key # pointer to keys structure +char field[ARB] # parameter name +int element # element of the array +char str[ARB] # output string +int maxch # maximum number of character + +int index, nk +pointer sp, temp, ptr +pointer strdic() + +begin + call smark (sp) + call salloc (temp, SZ_LINE, TY_CHAR) + index = strdic (field, Memc[temp], SZ_LINE, Memc[KY_WORDS(key)]) + call sfree (sp) + + if (index != 0) { + if (Memi[KY_NELEMS(key)+index-1] == 1) + ptr = Memi[KY_PTRS(key)+index-1] + else + ptr = Memi[KY_PTRS(key)+index-1] + (element - 1) * + Memi[KY_KINDICES(key)+index-1] + for (; Memc[ptr] == ' ';) + ptr = ptr + 1 + for (nk = 0; Memc[ptr+nk] != ' '; nk = nk + 1) + ; + call strcpy (Memc[ptr], str, min (nk, maxch)) + } else + call error (0, "Unknown string keyword in expression") +end diff --git a/noao/digiphot/lib/pttables/ptkid.x b/noao/digiphot/lib/pttables/ptkid.x new file mode 100644 index 00000000..8b4aafcb --- /dev/null +++ b/noao/digiphot/lib/pttables/ptkid.x @@ -0,0 +1,26 @@ +# PT_KID -- Decode a column specification into a name and an element. + +procedure pt_kid (column, name, element) + +char column[ARB] # column name +char name[ARB] # column name +int element # column element + +char left_bracket +int index +int stridx(), ctoi() +data left_bracket /'['/ + +begin + # Get the proper name in upper case and strip off and subscript. + call strcpy (column, name, SZ_FNAME) + call strupr (name) + index = stridx (left_bracket, name) + if (index > 0) { + name[index] = EOS + index = index + 1 + if (ctoi (column, index, element) < 0) + element = 1 + } else + element = 1 +end diff --git a/noao/digiphot/lib/pttables/ptkstat.x b/noao/digiphot/lib/pttables/ptkstat.x new file mode 100644 index 00000000..077afaf6 --- /dev/null +++ b/noao/digiphot/lib/pttables/ptkstat.x @@ -0,0 +1,137 @@ +include "../ptkeysdef.h" + +# PT_KSTATI -- Get an integer parameter from the keyword structure. + +int procedure pt_kstati (key, column, parameter) + +pointer key # pointer to the database strucuture +char column[ARB] # column name +int parameter # parameter to be returned + +char left_bracket +int index, element, value +pointer sp, kname +int strdic(), stridx(), ctoi() +data left_bracket /'['/ + +begin + call smark (sp) + call salloc (kname, KY_SZPAR, TY_CHAR) + + # Get the proper name in upper case and strip off the subscript. + call strcpy (column, Memc[kname], KY_SZPAR) + call strupr (Memc[kname]) + index = stridx (left_bracket, Memc[kname]) + if (index > 0) { + Memc[kname+index-1] = EOS + index = index + 1 + if (ctoi (column, index, element) < 0) + element = 1 + } else + element = 1 + + # Find the field. + index = strdic (Memc[kname], Memc[kname], KY_SZPAR, Memc[KY_WORDS(key)]) + + # Fetch the parameter. + switch (parameter) { + case KY_INDEX: + value = index + case KY_DATATYPE: + if (index > 0) + value = Memi[KY_TYPES(key)+index-1] + else + value = INDEFI + case KY_LENGTH: + if (index > 0) + value = Memi[KY_KINDICES(key)+index-1] + else + value = INDEFI + case KY_ELEMENT: + if (index <= 0) + value = INDEFI + else if (element >= 1 && element <= Memi[KY_NELEMS(key)+index-1]) + value = element + else + value = INDEFI + case KY_NUMELEMS: + value = Memi[KY_NELEMS(key)+index-1] + default: + value = INDEFI + } + + call sfree (sp) + + return (value) +end + + +# PT_KSTATS -- Get a string parameter from the keyword structure. + +procedure pt_kstats (key, column, parameter, str, maxch) + +pointer key # pointer to the database strucuture +char column[ARB] # column name +int parameter # parameter to be returned +char str[ARB] # output string +int maxch # maximum number of characters + +char left_bracket +int index, element, ip, len +pointer sp, kname +int strdic(), stridx(), ctoi() +data left_bracket /'['/ + +begin + call smark (sp) + call salloc (kname, KY_SZPAR, TY_CHAR) + + # Get the proper name in upper case and strip off the subscript. + call strcpy (column, Memc[kname], KY_SZPAR) + call strupr (Memc[kname]) + index = stridx (left_bracket, Memc[kname]) + if (index > 0) { + Memc[kname+index-1] = EOS + index = index + 1 + if (ctoi (column, index, element) < 0) + element = 1 + } else + element = 1 + + # Find the field. + index = strdic (Memc[kname], Memc[kname], KY_SZPAR, Memc[KY_WORDS(key)]) + + # Fetch the parameter. + switch (parameter) { + case KY_UNITSTR: + if (index <= 0) { + str[1] = EOS + } else if (index == 1) { + ip = 1 + len = Memi[KY_UINDICES(key)] + call strcpy (Memc[KY_UNITS(key)+ip-1], str, len) + } else { + ip = Memi[KY_UINDICES(key)+index-2] + 1 + len = Memi[KY_UINDICES(key)+index-1] - + Memi[KY_UINDICES(key)+index-2] + call strcpy (Memc[KY_UNITS(key)+ip-1], str, len) + } + case KY_FMTSTR: + if (index <= 0) { + str[1] = EOS + } else if (index == 1) { + ip = 1 + len = Memi[KY_FINDICES(key)] + call strcpy (Memc[KY_FORMATS(key)+ip-1], str, len) + } else { + ip = Memi[KY_FINDICES(key)+index-2] + 1 + len = Memi[KY_FINDICES(key)+index-1] - + Memi[KY_FINDICES(key)+index-2] + call strcpy (Memc[KY_FORMATS(key)+ip-1], str, len) + } + default: + str[1] = EOS + } + + call sfree (sp) +end diff --git a/noao/digiphot/lib/pttables/ptmkrec.x b/noao/digiphot/lib/pttables/ptmkrec.x new file mode 100644 index 00000000..a091812f --- /dev/null +++ b/noao/digiphot/lib/pttables/ptmkrec.x @@ -0,0 +1,86 @@ +include "../ptkeysdef.h" + +# PT_MKREC -- Construct the output record. + +procedure pt_mkrec (key, line, nchars, first_rec, recptr, ncontinue) + +pointer key # pointer to record structure +char line[ARB] # input line +int nchars # length of line array +int first_rec # first record read +int recptr # line per record index +int ncontinue # number of unique lines per record + +int i, cip, nokeys, nckeys, nkeys, nper_line, len_move +pointer op + +begin + # Reinitialize if this is the start of a new record. + if (recptr == 1) + nokeys = KY_NPKEYS(key) + + # Check repeat character. + if (line[nchars-2] == '*') + ncontinue = ncontinue + 1 + else + ncontinue = 0 + + # Fill in the record. + cip = 1 + if (ncontinue < 1) { + + nper_line = Memi[KY_NPLINE(key)+recptr-1] + nkeys = nokeys + nper_line + call amovki (int(1), Memi[KY_NELEMS(key)+nokeys], nper_line) + + len_move = 0 + do i = nokeys + 1, nkeys + len_move = len_move + Memi[KY_KINDICES(key)+i-1] + op = Memi[KY_PTRS(key)+nokeys] + call amovc (line[cip], Memc[op], len_move) + + cip = cip + len_move + recptr = recptr + 1 + nokeys = nkeys + + } else if (ncontinue == 1) { + + nckeys = nokeys + 1 + nkeys = nokeys + Memi[KY_NPLINE(key)+recptr-1] + + if (first_rec == YES) { + Memi[KY_NCONTINUE(key)+recptr-1] = KY_NLINES + do i = nckeys, nkeys + call malloc (Memi[KY_PTRS(key)+i-1], KY_NLINES * + Memi[KY_KINDICES(key)+i-1], TY_CHAR) + } + + do i = nckeys, nkeys { + call amovc (line[cip], Memc[Memi[KY_PTRS(key)+i-1]], + Memi[KY_KINDICES(key)+i-1]) + cip = cip + Memi[KY_KINDICES(key)+i-1] + } + + nokeys = nkeys + recptr = recptr + 1 + + } else { + + if (ncontinue > Memi[KY_NCONTINUE(key)+recptr-2]) { + Memi[KY_NCONTINUE(key)+recptr-2] = Memi[KY_NCONTINUE(key)+ + recptr-2] + KY_NLINES + do i = nckeys, nkeys + call realloc (Memi[KY_PTRS(key)+i-1], + Memi[KY_NCONTINUE(key)+recptr-2] * + Memi[KY_KINDICES(key)+i-1], TY_CHAR) + } + + do i = nckeys, nkeys { + op = Memi[KY_PTRS(key)+i-1] + (ncontinue - 1) * + Memi[KY_KINDICES(key)+i-1] + call amovc (line[cip], Memc[op], Memi[KY_KINDICES(key)+i-1]) + Memi[KY_NELEMS(key)+i-1] = ncontinue + cip = cip + Memi[KY_KINDICES(key)+i-1] + } + } +end diff --git a/noao/digiphot/lib/pttables/ptranges.x b/noao/digiphot/lib/pttables/ptranges.x new file mode 100644 index 00000000..7f37de19 --- /dev/null +++ b/noao/digiphot/lib/pttables/ptranges.x @@ -0,0 +1,38 @@ +# PT_RANGES -- Procedure to convert apphot ranges to the format expected +# by the xtools ranges package. + +int procedure pt_ranges (aranges, ranges, element, maxch) + +char aranges[ARB] # input ranges +char ranges[ARB] # output ranges +int element # range element +int maxch # maximum number of characters in ranges + +char left_bkt, right_bkt +int findex, lindex, nchars, ip +int stridx(), ctoi() +data left_bkt /'['/, right_bkt /']'/ + +begin + # Test for existence of ranges. + element = 1 + ranges[1] = EOS + if (aranges[1] == EOS) + return (OK) + + # Test for range delimiters. + findex = stridx (left_bkt, aranges) + lindex = stridx (right_bkt, aranges) + if (findex == 0 || lindex == 0 || (lindex <= findex + 1)) + return (ERR) + + # Compute the element selection. + ip = 1 + nchars = ctoi (aranges[findex+1], ip, element) + if (nchars == 0) + element = 1 + + # Copy the ranges portion. + call strcpy (aranges[findex+1], ranges, lindex - findex - 1) + return (OK) +end |