From fa080de7afc95aa1c19a6e6fc0e0708ced2eadc4 Mon Sep 17 00:00:00 2001 From: Joseph Hunkeler Date: Wed, 8 Jul 2015 20:46:52 -0400 Subject: Initial commit --- pkg/xtools/mef/Notes | 26 ++ pkg/xtools/mef/mefappfile.x | 109 +++++++++ pkg/xtools/mef/mefclose.x | 17 ++ pkg/xtools/mef/mefcpextn.x | 46 ++++ pkg/xtools/mef/mefdummyh.x | 84 +++++++ pkg/xtools/mef/mefencode.x | 530 +++++++++++++++++++++++++++++++++++++++++ pkg/xtools/mef/mefget.x | 183 ++++++++++++++ pkg/xtools/mef/mefgnbc.x | 55 +++++ pkg/xtools/mef/mefgval.x | 182 ++++++++++++++ pkg/xtools/mef/mefkfind.x | 75 ++++++ pkg/xtools/mef/mefksection.x | 174 ++++++++++++++ pkg/xtools/mef/mefldhdr.x | 118 +++++++++ pkg/xtools/mef/mefopen.x | 93 ++++++++ pkg/xtools/mef/mefrdhdr.x | 397 ++++++++++++++++++++++++++++++ pkg/xtools/mef/mefrdhdr.x_save | 529 ++++++++++++++++++++++++++++++++++++++++ pkg/xtools/mef/mefsetpl.x | 203 ++++++++++++++++ pkg/xtools/mef/mefwrhdr.x | 212 +++++++++++++++++ pkg/xtools/mef/mefwrhdr.x_save | 185 ++++++++++++++ pkg/xtools/mef/mefwrpl.x | 213 +++++++++++++++++ pkg/xtools/mef/mkpkg | 26 ++ 20 files changed, 3457 insertions(+) create mode 100644 pkg/xtools/mef/Notes create mode 100644 pkg/xtools/mef/mefappfile.x create mode 100644 pkg/xtools/mef/mefclose.x create mode 100644 pkg/xtools/mef/mefcpextn.x create mode 100644 pkg/xtools/mef/mefdummyh.x create mode 100644 pkg/xtools/mef/mefencode.x create mode 100644 pkg/xtools/mef/mefget.x create mode 100644 pkg/xtools/mef/mefgnbc.x create mode 100644 pkg/xtools/mef/mefgval.x create mode 100644 pkg/xtools/mef/mefkfind.x create mode 100644 pkg/xtools/mef/mefksection.x create mode 100644 pkg/xtools/mef/mefldhdr.x create mode 100644 pkg/xtools/mef/mefopen.x create mode 100644 pkg/xtools/mef/mefrdhdr.x create mode 100644 pkg/xtools/mef/mefrdhdr.x_save create mode 100644 pkg/xtools/mef/mefsetpl.x create mode 100644 pkg/xtools/mef/mefwrhdr.x create mode 100644 pkg/xtools/mef/mefwrhdr.x_save create mode 100644 pkg/xtools/mef/mefwrpl.x create mode 100644 pkg/xtools/mef/mkpkg (limited to 'pkg/xtools/mef') diff --git a/pkg/xtools/mef/Notes b/pkg/xtools/mef/Notes new file mode 100644 index 00000000..7f781840 --- /dev/null +++ b/pkg/xtools/mef/Notes @@ -0,0 +1,26 @@ + +mefwrhdr.x + Previuolsy we changed the value of INHERIT to NO. Now we pass + the card to the output file unchanged with the exception when + the output file is new, then we do not pass it along. 3/4/98 + +mefrdhdr.x + When a kernel section is given in the input file, it is + necessary to read the entire header in memory rather + than the 1st block. An error was found trying to get EXTNAME + value when the keyword was not located in the 1st block. + nz 10/2/03 +mefldhdr.x + New routine to read the entire header in memory. 10.02.03 + +================================================== + +mefrdhdr.x + Change mef_rdhdr...() to be a function now rather than a + procedure. This way we can return and EOF value to the + calling routine. + revised. Used mef_ldhdr() now and discard rd1st and rd2end. + Took out any eprintf statement and made the code much simpler. + Jan.7.04 + + diff --git a/pkg/xtools/mef/mefappfile.x b/pkg/xtools/mef/mefappfile.x new file mode 100644 index 00000000..eae4536b --- /dev/null +++ b/pkg/xtools/mef/mefappfile.x @@ -0,0 +1,109 @@ +include + +# MEFFAPPFILE.X -- Set of routines to append a FITS units to an FITS file. +# meff_app_file(mefi, mefo) +# mef_pakwr (out, card) +# mef_wrpgcount (out) +# mef_wrblank (out, nlines) + + +# MEF_APP_FILE -- Append a FITS file to an existant file. This means the +# first input unit needs to be changed from a Primary to an Extension Unit. + +procedure mef_app_file (mefi, mefo) + +pointer mefi #I input mef descriptor +pointer mefo #O output mef descriptor + +char dname[1] +int off, status +bool in_phdu +int access(), mef_rdhdr_gn() + +errchk mef_rdhdr_gn + +begin + + # If output file does not exist create a dummy extension + if (access(MEF_FNAME(mefo), 0,0) == NO) { + dname[1] = EOS + call mef_dummyhdr (MEF_FD(mefo),dname) + MEF_ACMODE(mefo) = APPEND + } + + in_phdu = true # The input file has a PHDU + + # Read the first input header unit (PHDU) and change to extension + # unit while writing to output file. + status = mef_rdhdr_gn (mefi,0) + if (status == EOF) + call error (13, "EOF encountered on input file") + call mef_wrhdr (mefi, mefo, in_phdu) + + # Check for dataless unit; if so the data pointer is at the + # end of the last header block. + + if (MEF_POFF(mefi) == INDEFI) + off = MEF_HOFF(mefi) + ((MEF_HSIZE(mefi)+2879)/2880)*1440 + else + off = MEF_POFF(mefi) + + # Now copy the data + call seek (MEF_FD(mefi), off) + call fcopyo (MEF_FD(mefi), MEF_FD(mefo)) +end + + +# MEF_PAKWR -- Pack a character buffer and write to the output buffer. + +procedure mef_pakwr (out, card) + +int out #I Output file descriptor +char card[ARB] #I Input FITS card + +begin + call achtcb (card, card, 80) + call write(out, card, 40) +end + + +# MEF_WRPGCOUNT -- Write PCOUNT and GCOUNT to the output buffer. + +procedure mef_wrpgcount (out) + +int out #I file descriptor + +char line[80] + +begin + call mef_encodei ("PCOUNT", 0, line, "No 'random' parameters") + call mef_pakwr (out, line) + call mef_encodei ("GCOUNT", 1, line, "Only one group") + call mef_pakwr (out, line) +end + + +# MEF_WRBLANK -- Write a number of blank lines into the output buffer. +# we reach the END card in the 1st block but we run out +# to the 2nd block in the output file. Now fill it up +# with blank. + +procedure mef_wrblank (out, olines) + +int out #I output file descriptor +int olines #I number of blank lines + +int nlines, i, nbk +char card[80] + +begin + nlines = 36 - mod(olines,36) + + do i =1, 80 + card[i] = ' ' + + call achtcb (card, card, 80) + for(i=1; i<=nlines; i=i+1) + call write(out, card, 40) + return +end diff --git a/pkg/xtools/mef/mefclose.x b/pkg/xtools/mef/mefclose.x new file mode 100644 index 00000000..cbae6d54 --- /dev/null +++ b/pkg/xtools/mef/mefclose.x @@ -0,0 +1,17 @@ +include + +# MEF_CLOSE -- Closes mef file descriptor and free up mef memory +# descriptor. + +procedure mef_close(mef) + +pointer mef #I Mef descriptor + +begin + call close(MEF_FD(mef)) + + if (MEF_HDRP(mef) != NULL) + call mfree(MEF_HDRP(mef), TY_CHAR) + + call mfree (mef, TY_STRUCT) +end diff --git a/pkg/xtools/mef/mefcpextn.x b/pkg/xtools/mef/mefcpextn.x new file mode 100644 index 00000000..b1d00af2 --- /dev/null +++ b/pkg/xtools/mef/mefcpextn.x @@ -0,0 +1,46 @@ +include +include + +# MEF_COPY_EXTN -- Append a FITS unit to the output file. + +procedure mef_copy_extn (mefi, mefo, gn) + +pointer mefi #I input mef descriptor +pointer mefo #I output mef descriptor +int gn #I input group number + +char ibuf[FITS_BLKSZ_CHAR] +int ndim, totpix, i, k, in, out, status +int read(), mef_rdhdr_gn(), mef_totpix() +bool iphdu + +errchk mef_rdhdr_gn + +begin + iphdu = (gn == 0) + + status = mef_rdhdr_gn (mefi, gn) + if (status == EOF) + call error (13, " EOF encountered on input file") + + call mef_wrhdr (mefi, mefo, iphdu) + MEF_ACMODE(mefo) = APPEND + + # Count the pixels and write data. + ndim = MEF_NDIM(mefi) + if (ndim > 0 || MEF_PCOUNT(mefi) > 0) { + # Set in multiple of FITS_BLKSZ_CHAR + totpix = mef_totpix(mefi) + totpix = (totpix + 1439)/1440 + + in = MEF_FD(mefi) + out = MEF_FD(mefo) + + # Position the input file to the beginning of the pixel area. + call seek (in, MEF_POFF(mefi)) + do i = 1, totpix { + k = read (in, ibuf, 1440) + call write (out, ibuf, 1440) + } + } +end diff --git a/pkg/xtools/mef/mefdummyh.x b/pkg/xtools/mef/mefdummyh.x new file mode 100644 index 00000000..ba0d38dd --- /dev/null +++ b/pkg/xtools/mef/mefdummyh.x @@ -0,0 +1,84 @@ +include + +# MEF_DUMMYHDR -- Write a dummy Primary header Unit with no data to a new file. +# Optionaly a header file with user keywords can be used. + +procedure mef_dummyhdr (out, hdrfname) + +int out #I File descriptor +char hdrfname[ARB] #I Header filename + +char card[LEN_CARD] +pointer sp, path, op +int n, nlines, i, nchars, FD +int strlen(), open(), getline(), strncmp() + +begin + call smark(sp) + call salloc (path, SZ_PATHNAME, TY_CHAR) + + n = 0 + call mef_encodeb ("SIMPLE", YES, card, "FITS STANDARD") + call mef_pakwr (out, card) + n = n + 1 + + call mef_encodei ("BITPIX", 8, card, "Character information") + call mef_pakwr (out, card) + n = n + 1 + + call mef_encodei ("NAXIS", 0, card, "No image data array present") + call mef_pakwr (out, card) + n = n + 1 + + call mef_encodeb ("EXTEND", YES, card, + "There maybe standard extensions") + call mef_pakwr (out, card) + n = n + 1 + + call mef_encodec ("ORIGIN", FITS_ORIGIN, strlen(FITS_ORIGIN), + card, "FITS file originator") + call mef_pakwr (out, card) + n = n + 1 + + call mef_encode_date (Memc[path], SZ_PATHNAME) + call mef_encodec ("DATE", Memc[path], strlen(Memc[path]), + card, "Date FITS file was generated") + call mef_pakwr (out, card) + n = n + 1 + + # Write a header file if one is given + if (hdrfname[1] != EOS) { + fd = open (hdrfname, READ_ONLY, TEXT_FILE) + nchars = getline(fd, Memc[path]) + repeat { + if ((strncmp (Memc[path], "SIMPLE", 6) == 0) || + (strncmp (Memc[path], "BITPIX", 6) == 0) || + (strncmp (Memc[path], "NAXIS", 5) == 0) ) + nchars = getline(fd, Memc[path]) + for (op=nchars-1; op <= LEN_CARD; op=op+1) + Memc[path+op] = ' ' + Memc[path+LEN_CARD] = EOS + call mef_pakwr (out, Memc[path]) + n = n + 1 + if (n == 36) + n = 0 + nchars = getline(fd, Memc[path]) + } until (nchars == EOF) + call close (fd) + } + + Memc[path] = ' ' + call amovkc (Memc[path], card, 80) + call strcpy ("END", card, 3) + card[4] = ' ' # Clear EOS mark + call mef_pakwr (out, card) + + n = n + 1 + + call amovkc (" ", card, 80) + nlines = 36 - n + for (i=1; i<= nlines; i=i+1) + call mef_pakwr (out, card) + + call sfree (sp) +end diff --git a/pkg/xtools/mef/mefencode.x b/pkg/xtools/mef/mefencode.x new file mode 100644 index 00000000..57b5637d --- /dev/null +++ b/pkg/xtools/mef/mefencode.x @@ -0,0 +1,530 @@ +include +include + +# MEFENCODE -- Routines to encode keyword, value and comment into a FITS card + +define LEN_OBJECT 63 +define CENTURY 1900 + +# MEF_ENCODEB -- Procedure to encode a boolean parameter into a FITS card. + +procedure mef_encodeb (keyword, param, card, comment) + +char keyword[ARB] #I FITS keyword +int param #I integer parameter equal to YES/NO +char card[ARB] #O FITS card image +char comment[ARB] #I FITS comment string + +char truth + +begin + if (param == YES) + truth = 'T' + else + truth = 'F' + + call sprintf (card, LEN_CARD, "%-8.8s= %20c / %-47.47s") + call pargstr (keyword) + call pargc (truth) + call pargstr (comment) +end + + +# MEF_ENCODEI -- Procedure to encode an integer parameter into a FITS card. + +procedure mef_encodei (keyword, param, card, comment) + +char keyword[ARB] #I FITS keyword +int param #I integer parameter +char card[ARB] #O FITS card image +char comment[ARB] #I FITS comment string + +begin + call sprintf (card, LEN_CARD, "%-8.8s= %20d / %-47.47s") + call pargstr (keyword) + call pargi (param) + call pargstr (comment) +end + + +# MEF_ENCODEL -- Procedure to encode a long parameter into a FITS card. + +procedure mef_encodel (keyword, param, card, comment) + +char keyword[ARB] #I FITS keyword +long param #I long integer parameter +char card[ARB] #O FITS card image +char comment[ARB] #I FITS comment string + +begin + call sprintf (card, LEN_CARD, "%-8.8s= %20d / %-47.47s") + call pargstr (keyword) + call pargl (param) + call pargstr (comment) +end + + +# MEF_ENCODER -- Procedure to encode a real parameter into a FITS card. + +procedure mef_encoder (keyword, param, card, comment, precision) + +char keyword[ARB] #I FITS keyword +real param #I real parameter +char card[ARB] #O FITS card image +char comment[ARB] #I FITS comment card +int precision #I precision of real + +begin + call sprintf (card, LEN_CARD, "%-8.8s= %20.*e / %-47.47s") + call pargstr (keyword) + call pargi (precision) + call pargr (param) + call pargstr (comment) +end + + +# MEF_ENCODED -- Procedure to encode a double parameter into a FITS card. + +procedure mef_encoded (keyword, param, card, comment, precision) + +char keyword[ARB] #I FITS keyword +double param #I double parameter +char card[ARB] #O FITS card image +char comment[ARB] #I FITS comment string +int precision #I FITS precision + +begin + call sprintf (card, LEN_CARD, "%-8.8s= %20.*e / %-47.47s") + call pargstr (keyword) + call pargi (precision) + call pargd (param) + call pargstr (comment) +end + + +# MEF_ENCODE_AXIS -- Procedure to add the axis number to axis dependent +# keywords. + +procedure mef_encode_axis (root, keyword, axisno) + +char root[ARB] #I FITS root keyword +char keyword[ARB] #O FITS keyword +int axisno #I FITS axis number + +begin + call strcpy (root, keyword, SZ_KEYWORD) + call sprintf (keyword, SZ_KEYWORD, "%-5.5s%-3.3s") + call pargstr (root) + call pargi (axisno) +end + + +# MEF_ENCODEC -- Procedure to encode an IRAF string parameter into a FITS card. + +procedure mef_encodec (keyword, param, maxch, card, comment) + +char keyword[LEN_CARD] #I FITS keyword +char param[LEN_CARD] #I FITS string parameter +int maxch #I maximum number of characters in param +char card[LEN_CARD+1] #O FITS card image +char comment[LEN_CARD] #I comment string + +int nblanks, maxchar, slashp + +begin + maxchar = max(8, min (maxch, LEN_OBJECT)) + slashp = 32 + nblanks = LEN_CARD - (slashp + 1) + if (maxchar >= 19) { + slashp = 1 + nblanks = max (LEN_OBJECT - maxchar - slashp+3, 1) + } + call sprintf (card, LEN_CARD, "%-8.8s= '%*.*s' %*t/ %*.*s") + call pargstr (keyword) + call pargi (-maxchar) + call pargi (maxchar) + call pargstr (param) + call pargi (slashp) + call pargi (-nblanks) + call pargi (nblanks) + call pargstr (comment) +end + + +# MEF_ENCODE_DATE -- Procedure to encode the date in the form dd/mm/yy. + +procedure mef_encode_date (datestr, szdate) + +char datestr[ARB] # string containing the date +int szdate # number of chars in the date string + +long ctime +int time[LEN_TMSTRUCT] +long clktime() + +begin + ctime = clktime (long (0)) + call brktime (ctime, time) + + call sprintf (datestr, szdate, "%02s/%02s/%02s") + call pargi (TM_MDAY(time)) + call pargi (TM_MONTH(time)) + call pargi (mod (TM_YEAR(time), CENTURY)) +end + + +# MEF_AKWC -- Encode keyword, value and comment into a FITS card and +# append it to a buffer pointed by pn. + +procedure mef_akwc (keyword, value, len, comment, pn) + +char keyword[SZ_KEYWORD] # keyword name +char value[ARB] # Keyword value +int len # Lenght of value +char comment[ARB] # Comment +pointer pn # Pointer to a char area +char card[LEN_CARD] + +begin + call mef_encodec (keyword, value, len, card, comment) + call amovc (card, Memc[pn], LEN_CARD) + pn = pn + LEN_CARD +end + + +# MEF_AKWB -- Encode keyword, value and comment into a FITS card and +# append it to a buffer pointed by pn. + +procedure mef_akwb (keyword, value, comment, pn) + +char keyword[SZ_KEYWORD] # I keyword name +int value # I Keyword value (YES, NO) +char comment[ARB] # I Comment +pointer pn # I/O Pointer to a char area + +pointer sp, pc + +begin + call smark(sp) + call salloc (pc, LEN_CARD, TY_CHAR) + + call mef_encodeb (keyword, value, Memc[pc], comment) + call amovc (Memc[pc], Memc[pn], LEN_CARD) + pn = pn + LEN_CARD + + call sfree(sp) +end + + +# MEF_AKWI -- Encode keyword, value and comment into a FITS card and +# append it to a buffer pointed by pn. + +procedure mef_akwi (keyword, value, comment, pn) + +char keyword[SZ_KEYWORD] # I keyword name +int value # I Keyword value +char comment[ARB] # I Comment +pointer pn # I/O Pointer to a char area + +pointer sp, pc + +begin + call smark(sp) + call salloc (pc, LEN_CARD, TY_CHAR) + + call mef_encodei (keyword, value, Memc[pc], comment) + call amovc (Memc[pc], Memc[pn], LEN_CARD) + pn = pn + LEN_CARD + + call sfree(sp) +end + + +# MEF_AKWR -- Encode keyword, value and comment into a FITS card and +# append it to a buffer pointed by pn. + +procedure mef_akwr (keyword, value, comment, precision, pn) + +char keyword[SZ_KEYWORD] # I keyword name +real value # I Keyword value +char comment[ARB] # I Comment +int precision +pointer pn # I/O Pointer to a char area + +pointer sp, pc + +begin + call smark(sp) + call salloc (pc, LEN_CARD, TY_CHAR) + + call mef_encoder (keyword, value, Memc[pc], comment, precision) + call amovc (Memc[pc], Memc[pn], LEN_CARD) + pn = pn + LEN_CARD + + call sfree(sp) +end + + +# MEF_AKWD -- Encode keyword, value and comment into a FITS card and +# append it to a buffer pointed by pn. + +procedure mef_akwd (keyword, value, comment, precision, pn) + +char keyword[SZ_KEYWORD] # I keyword name +double value # I Keyword value +char comment[ARB] # I Comment +int precision +pointer pn # I/O Pointer to a char area + +pointer sp, pc + +begin + call smark(sp) + call salloc (pc, LEN_CARD, TY_CHAR) + + call mef_encoded (keyword, value, Memc[pc], comment, precision) + call amovc (Memc[pc], Memc[pn], LEN_CARD) + pn = pn + LEN_CARD + + call sfree(sp) +end + + +# NOTE: This local version of the xtools routine call handle starting +# index of zero (0). Taken from dataio/lib and modified. NZ March, 98 +# +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include + +define FIRST 1 # Default starting range +define LAST MAX_INT # Default ending range +define STEP 1 # Default step +define NULL -1 # Ranges delimiter + +# DECODE_RANGES -- Parse a string containing a list of integer numbers or +# ranges, delimited by either spaces or commas. Return as output a list +# of ranges defining a list of numbers, and the count of list numbers. +# Range limits must be positive nonnegative integers. ERR is returned as +# the function value if a conversion error occurs. The list of ranges is +# delimited by a single NULL. + +int procedure ldecode_ranges (range_string, ranges, max_ranges, nvalues) + +char range_string[ARB] # Range string to be decoded +int ranges[3, max_ranges] # Range array +int max_ranges # Maximum number of ranges +int nvalues # The number of values in the ranges + +int ip, nrange, first, last, step, ctoi() + +begin + ip = 1 + nvalues = 0 + + do nrange = 1, max_ranges - 1 { + # Defaults to all positive integers + first = FIRST + last = LAST + step = STEP + + # Skip delimiters + while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') + ip = ip + 1 + + # Get first limit. + # Must be a number, '-', 'x', or EOS. If not return ERR. + if (range_string[ip] == EOS) { # end of list + if (nrange == 1) { + # Null string defaults + ranges[1, 1] = first + ranges[2, 1] = last + ranges[3, 1] = step + ranges[1, 2] = NULL + nvalues = nvalues + abs (last-first) / step + 1 + return (OK) + } else { + ranges[1, nrange] = NULL + return (OK) + } + } else if (range_string[ip] == '-') + ; + else if (range_string[ip] == 'x') + ; + else if (IS_DIGIT(range_string[ip])) { # ,n.. + if (ctoi (range_string, ip, first) == 0) + return (ERR) + } else + return (ERR) + + # Skip delimiters + while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') + ip = ip + 1 + + # Get last limit + # Must be '-', or 'x' otherwise last = first. + if (range_string[ip] == 'x') + ; + else if (range_string[ip] == '-') { + ip = ip + 1 + while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') + ip = ip + 1 + if (range_string[ip] == EOS) + ; + else if (IS_DIGIT(range_string[ip])) { + if (ctoi (range_string, ip, last) == 0) + return (ERR) + } else if (range_string[ip] == 'x') + ; + else + return (ERR) + } else + last = first + + # Skip delimiters + while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') + ip = ip + 1 + + # Get step. + # Must be 'x' or assume default step. + if (range_string[ip] == 'x') { + ip = ip + 1 + while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') + ip = ip + 1 + if (range_string[ip] == EOS) + ; + else if (IS_DIGIT(range_string[ip])) { + if (ctoi (range_string, ip, step) == 0) + ; + } else if (range_string[ip] == '-') + ; + else + return (ERR) + } + + # Output the range triple. + ranges[1, nrange] = first + ranges[2, nrange] = last + ranges[3, nrange] = step + nvalues = nvalues + abs (last-first) / step + 1 + } + + return (ERR) # ran out of space +end + + +# GET_NEXT_NUMBER -- Given a list of ranges and the current file number, +# find and return the next file number. Selection is done in such a way +# that list numbers are always returned in monotonically increasing order, +# regardless of the order in which the ranges are given. Duplicate entries +# are ignored. EOF is returned at the end of the list. + +int procedure lget_next_number (ranges, number) + +int ranges[ARB] # Range array +int number # Both input and output parameter + +int ip, first, last, step, next_number, remainder + +begin + # If number+1 is anywhere in the list, that is the next number, + # otherwise the next number is the smallest number in the list which + # is greater than number+1. + + number = number + 1 + next_number = MAX_INT + + for (ip=1; ranges[ip] != NULL; ip=ip+3) { + first = min (ranges[ip], ranges[ip+1]) + last = max (ranges[ip], ranges[ip+1]) + step = ranges[ip+2] + if (number >= first && number <= last) { + remainder = mod (number - first, step) + if (remainder == 0) + return (number) + if (number - remainder + step <= last) + next_number = number - remainder + step + } else if (first > number) + next_number = min (next_number, first) + } + + if (next_number == MAX_INT) + return (EOF) + else { + number = next_number + return (number) + } +end + + +# GET_PREVIOUS_NUMBER -- Given a list of ranges and the current file number, +# find and return the previous file number. Selection is done in such a way +# that list numbers are always returned in monotonically decreasing order, +# regardless of the order in which the ranges are given. Duplicate entries +# are ignored. EOF is returned at the end of the list. + +int procedure lget_previous_number (ranges, number) + +int ranges[ARB] # Range array +int number # Both input and output parameter + +int ip, first, last, step, next_number, remainder + +begin + # If number-1 is anywhere in the list, that is the previous number, + # otherwise the previous number is the largest number in the list which + # is less than number-1. + + number = number - 1 + next_number = 0 + + for (ip=1; ranges[ip] != NULL; ip=ip+3) { + first = min (ranges[ip], ranges[ip+1]) + last = max (ranges[ip], ranges[ip+1]) + step = ranges[ip+2] + if (number >= first && number <= last) { + remainder = mod (number - first, step) + if (remainder == 0) + return (number) + if (number - remainder >= first) + next_number = number - remainder + } else if (last < number) { + remainder = mod (last - first, step) + if (remainder == 0) + next_number = max (next_number, last) + else if (last - remainder >= first) + next_number = max (next_number, last - remainder) + } + } + + if (next_number == 0) + return (EOF) + else { + number = next_number + return (number) + } +end + + +# IS_IN_RANGE -- Test number to see if it is in range. + +bool procedure lis_in_range (ranges, number) + +int ranges[ARB] # Range array +int number # Number to be tested against ranges + +int ip, first, last, step + +begin + for (ip=1; ranges[ip] != NULL; ip=ip+3) { + first = min (ranges[ip], ranges[ip+1]) + last = max (ranges[ip], ranges[ip+1]) + step = ranges[ip+2] + if (number >= first && number <= last) + if (mod (number - first, step) == 0) + return (true) + } + + return (false) +end diff --git a/pkg/xtools/mef/mefget.x b/pkg/xtools/mef/mefget.x new file mode 100644 index 00000000..4860c99e --- /dev/null +++ b/pkg/xtools/mef/mefget.x @@ -0,0 +1,183 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include + +# MEFGETB -- 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 mefgetb (mef, key) + +pointer mef # image descriptor +char key[ARB] # parameter to be returned + +pointer sp, kv, line +int strlen() +bool bval + +errchk mef_findkw + +begin + call smark (sp) + call salloc (kv, LEN_CARD, TY_CHAR) + call salloc (line, LEN_CARD, TY_CHAR) + + call mef_findkw (MEF_HDRP(mef), key, Memc[kv]) + if (strlen(Memc[kv]) != 1) { + call sprintf(Memc[line], LEN_CARD, "Invalid boolean value: '%s'") + call pargstr (Memc[kv]) + call error (0,Memc[line]) + }else + bval = Memc[kv] == 'T' + + call sfree (sp) + return (bval) +end + + +# MEFGETC -- Get an image header parameter of type char. + +char procedure mefgetc (mef, key) + +pointer mef # image descriptor +char key[ARB] # parameter to be returned +long mefgetl() + +begin + return (mefgetl (mef, key)) +end + + +# MEFGETD -- 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 mefgetd (mef, key) + +pointer mef # image descriptor +char key[ARB] # parameter to be returned + +int ip +double dval +pointer sp, sval +int ctod() +errchk syserrs, mefgstr + +begin + call smark (sp) + call salloc (sval, SZ_LINE, TY_CHAR) + + ip = 1 + call mefgstr (mef, key, Memc[sval], SZ_LINE) + if(Memc[sval]==EOS) + call syserrs (SYS_IDBKEYNF, key) + if (ctod (Memc[sval], ip, dval) == 0) + call syserrs (SYS_IDBTYPE, key) + + call sfree (sp) + return (dval) +end + + +# MEFGETI -- Get an image header parameter of type integer. + +int procedure mefgeti (mef, key) + +pointer mef # image descriptor +char key[ARB] # parameter to be returned + +long lval, mefgetl() +errchk mefgetl + +begin + lval = mefgetl (mef, key) + if (IS_INDEFL(lval)) + return (INDEFI) + else + return (lval) +end + + +# MEFGETL -- Get an image header parameter of type long integer. + +long procedure mefgetl (mef, key) + +pointer mef # image descriptor +char key[ARB] # parameter to be returned + +double dval, mefgetd() +errchk mefgetd + +begin + dval = mefgetd (mef, key) + if (IS_INDEFD(dval)) + return (INDEFL) + else + return (nint (dval)) +end + + +# MEFGETR -- Get an image header parameter of type real. + +real procedure mefgetr (mef, key) + +pointer mef # image descriptor +char key[ARB] # parameter to be returned + +double dval, mefgetd() +errchk mefgetd + +begin + dval = mefgetd (mef, key) + if (IS_INDEFD(dval)) + return (INDEFR) + else + return (dval) +end + + +# MEFGETS -- Get an image header parameter of type short integer. + +short procedure mefgets (mef, key) + +pointer mef # image descriptor +char key[ARB] # parameter to be returned + +long lval, mefgetl() +errchk mefgetl + +begin + lval = mefgetl (mef, key) + if (IS_INDEFL(lval)) + return (INDEFS) + else + return (lval) +end + + +# MEFGSTR -- 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 mefgstr (mef, key, outstr, maxch) + +pointer mef # image descriptor +char key[ARB] # parameter to be returned +char outstr[ARB] # output string to receive parameter value +int maxch + +pointer sp, kv + +begin + call smark (sp) + call salloc (kv, LEN_CARD, TY_CHAR) + + # Find the record. + iferr (call mef_findkw (MEF_HDRP(mef), key, Memc[kv])) + Memc[kv] = EOS + + call strcpy (Memc[kv], outstr, min (maxch, LEN_CARD)) + + call sfree (sp) +end diff --git a/pkg/xtools/mef/mefgnbc.x b/pkg/xtools/mef/mefgnbc.x new file mode 100644 index 00000000..2d370893 --- /dev/null +++ b/pkg/xtools/mef/mefgnbc.x @@ -0,0 +1,55 @@ +include + +# MEF_GNBC -- Get the Number of Blank Cards in a FITS header pointed by +# mef. This is the number of cards available to insert before an expantion by +# one block is required. If the header has not being read and EOF (-2) is +# returned. + +int procedure mef_gnbc (mef) + +pointer mef + +int len, hd, ip, nbc, hsize, k, ncards +int strlen(), strncmp() + +begin + if (MEF_HDRP(mef) == NULL) + return (EOF) + + hd = MEF_HDRP(mef) + len = strlen(Memc[hd]) + + # Go to the end of buffer and get last line + + ip = hd + MEF_HSIZE(mef) - LEN_CARDNL + + # See if line is blank + + nbc = 0 + while (ip > 0) { + do k = 0, LEN_CARD-1 + if (Memc[ip+k] != ' ') + break + + if (k != LEN_CARD && k != 0) # blank keyw card + break + else if (k == 0) { + if (strncmp ("END ", Memc[ip], 8) == 0) { + ip = ip - LEN_CARDNL + next + } else + break + } else + nbc = nbc + 1 + ip = ip - LEN_CARDNL + } + + hsize = MEF_HSIZE(mef) + ncards = (hsize + 80)/81 + + ncards = ((ncards + 35)/36)*36 - ncards + nbc = nbc + ncards + + return (nbc) +end + diff --git a/pkg/xtools/mef/mefgval.x b/pkg/xtools/mef/mefgval.x new file mode 100644 index 00000000..aa481a2a --- /dev/null +++ b/pkg/xtools/mef/mefgval.x @@ -0,0 +1,182 @@ +include +include + + +# MEFGVAL.X -- Set of routines to decode the value of a FITS keyword given +# the whole card. + + +# MEF_GVALI -- Return the integer value of a FITS encoded card. + +procedure mef_gvali (card, ival) + +char card[ARB] #I card to be decoded +int ival #O receives integer value + +int ip, ctoi() +char sval[MEF_SZVALSTR] + +begin + call mef_gvalt (card, sval, MEF_SZVALSTR) + ip = 1 + if (ctoi (sval, ip, ival) <= 0) + ival = 0 +end + + +# MEF_GVALR -- Return the real value of a FITS encoded card. + +procedure mef_gvalr (card, rval) + +char card[ARB] #I card to be decoded +real rval #O receives integer value + +int ip, ctor() +char sval[MEF_SZVALSTR] + +begin + call mef_gvalt (card, sval, MEF_SZVALSTR) + ip = 1 + if (ctor (sval, ip, rval) <= 0) + rval = 0.0 +end + + +# MEF_GVALD -- Return the double value of a FITS encoded card. + +procedure mef_gvald (card, dval) + +char card[ARB] #I card to be decoded +double dval #O receives integer value + +int ip, ctod() +char sval[MEF_SZVALSTR] + +begin + call mef_gvalt (card, sval, MEF_SZVALSTR) + ip = 1 + if (ctod (sval, ip, dval) <= 0) + dval = 0.0 +end + + +# MEF_GVALB -- Return the boolean/integer value of a FITS encoded card. + +procedure mef_gvalb (card, bval) + +char card[ARB] #I card to be decoded +int bval #O receives YES/NO + +char sval[MEF_SZVALSTR] + +begin + call mef_gvalt (card, sval, MEF_SZVALSTR) + if (sval[1] == 'T') + bval = YES + else + bval = NO +end + + +# MEF_GVALT -- Get the string value of a FITS encoded card. Strip leading +# and trailing whitespace and any quotes. + +procedure mef_gvalt (card, outstr, maxch) + +char card[ARB] #I FITS card to be decoded +char outstr[ARB] #O output string to receive parameter value +int maxch #I length of outstr + +int ip, op +int ctowrd(), strlen() + +begin + ip = FITS_STARTVALUE + if (ctowrd (card, ip, outstr, maxch) > 0) { + # Strip trailing whitespace. + op = strlen (outstr) + while (op > 0 && (IS_WHITE(outstr[op]) || outstr[op] == '\n')) + op = op - 1 + outstr[op+1] = EOS + } else + outstr[1] = EOS +end + + +# MEF_GETCMT -- Get the comment field of a FITS encoded card. + +procedure mef_getcmt (card, comment, maxch) + +char card[ARB] #I FITS card to be decoded +char comment[ARB] #O output string to receive comment +int maxch #I max chars out + +int ip, op +int lastch + +begin + # Find the slash which marks the beginning of the comment field. + ip = FITS_ENDVALUE + 1 + while (card[ip] != EOS && card[ip] != '\n' && card[ip] != '/') + ip = ip + 1 + + # Copy the comment to the output string, omitting the /, any + # trailing blanks, and the newline. + + lastch = 0 + do op = 1, maxch { + if (card[ip] == EOS) + break + ip = ip + 1 + comment[op] = card[ip] + if (card[ip] > ' ') + lastch = op + } + comment[lastch+1] = EOS +end + + +# MEF_GLTM -- Procedure to convert an input time stream with hh:mm:ss +# and date stream dd/mm/yy into seconds from jan 1st 1980. + +procedure mef_gltm (time, date, limtime) + +char time[ARB] #I time +char date[ARB] #I date +int limtime #O seconds + +int hr,mn,sec,days,month,year, ip, iy, days_per_year, ctoi(),i +int month_to_days[12], adays + +data month_to_days / 0,31,59,90,120,151,181,212,243,273,304,334/ + +begin + ip = 1 + ip = ctoi (time, ip, hr) + ip = 1 + ip = ctoi (time[4], ip, mn) + ip = 1 + ip = ctoi (time[7], ip, sec) + + sec = sec + mn * 60 + hr * 3600 + + ip = 1 + ip = ctoi (date, ip, days) + ip = 1 + ip = ctoi (date[4], ip, month) + ip = 1 + ip = ctoi (date[7], ip, year) + + days_per_year = 0 + + iy = year + 1900 + do i = 1, iy - 1980 + days_per_year = days_per_year + 365 + + adays= (year-80)/4 + if (month > 2) adays=adays+1 + + days = adays + days-1 + days_per_year + month_to_days[month] + + limtime = sec + days * 86400 +end diff --git a/pkg/xtools/mef/mefkfind.x b/pkg/xtools/mef/mefkfind.x new file mode 100644 index 00000000..bfcf393b --- /dev/null +++ b/pkg/xtools/mef/mefkfind.x @@ -0,0 +1,75 @@ +include +include + +# MEF_FINDKW -- Search the header database for a particular keyword +# and get its value. An error is returned if the keyword is not found. + +procedure mef_findkw (hdrp, key, keywval) + +pointer hdrp #I pointer to header buffer +char key[ARB] #I Keyword name +char keywval[ARB] #O string value + +pointer sp, ukey, lkey, ip +int nchars, lch, uch, ch, i +int gstrcpy() + +errchk syserrs + +begin + call smark (sp) + call salloc (ukey, SZ_KEYWORD, TY_CHAR) + call salloc (lkey, SZ_KEYWORD, TY_CHAR) + + # Prepare U/L FITS keywords, truncated to 8 chars. + nchars = gstrcpy (key, Memc[lkey], SZ_KEYWORD) + call strlwr (Memc[lkey]) + nchars = gstrcpy (key, Memc[ukey], SZ_KEYWORD) + call strupr (Memc[ukey]) + + # Search for the FIRST occurrence of a record with the given key. + + # Fixed length (80 character), newline terminated records, EOS + # terminated record group. + + # Simple fast search, fixed length records. Case insensitive + # keyword match. + + lch = Memc[lkey] + uch = Memc[ukey] + + for (ip=hdrp; Memc[ip] != EOS; ip=ip+LEN_CARDNL) { + ch = Memc[ip] + if (ch == EOS) + break + else if (ch != lch && ch != uch) + next + else { + # Abbreviations are not permitted. + ch = Memc[ip+nchars] + if (ch != ' ' && ch != '=') + next + } + + # First char matches; check rest of string. + do i = 1, nchars-1 { + ch = Memc[ip+i] + if (ch != Memc[lkey+i] && ch != Memc[ukey+i]) { + ch = 0 + break + } + } + + if (ch != 0) { + #Copy card starting at ip + call mef_gvalt (Memc[ip], keywval, MEF_SZVALSTR) + call sfree (sp) + return + } + } + + # Keyword not found + call syserrs (SYS_IDBKEYNF, key) + + call sfree (sp) +end diff --git a/pkg/xtools/mef/mefksection.x b/pkg/xtools/mef/mefksection.x new file mode 100644 index 00000000..e6a44b7b --- /dev/null +++ b/pkg/xtools/mef/mefksection.x @@ -0,0 +1,174 @@ +include +include +include + +define KS_EXTNAME 1 +define KS_EXTVER 2 + +# MEF_KSECTION -- Procedure to parse and analyze a string of the form +# +# "(extname=)name,(extver=)23" +# +# The numeric field is position depend if it does not have 'extver'. + +procedure mef_ksection (ksection, extname, extver) + +char ksection[ARB] #I String with kernel section +char extname[ARB] #O Extname +int extver #O Extver + +int ctotok(),ip, jp, nident, nexpr +int junk, nch, lexnum(), ty, token, ival +char outstr[LEN_CARD] +char identif[LEN_CARD] +int lex_type, mef_klex(), ctoi() + +begin + + extname[1] = EOS + extver = INDEFL + ip = 1 + nident = 0 + nexpr = 0 + identif[1] = EOS + + repeat { + # Advance to the next keyword. + token = ctotok (ksection, ip, outstr, LEN_CARD) + + switch (token) { + case TOK_EOS: + break + case TOK_NEWLINE: + break + case TOK_NUMBER: + if (nexpr != 1) + call error(13, + "Numeric value only allow as second term in ksection") + jp = 1 + ty = lexnum (outstr, jp, nch) + if (ty != LEX_DECIMAL) + call error(13, "Number is not decimal") + jp = 1 + junk = ctoi(outstr, jp, ival) + extver = ival + nexpr = nexpr + 1 + case TOK_PUNCTUATION: + if (outstr[1] == ',' && identif[1] == EOS) + call error(13,"syntax error in kernel section") + case TOK_STRING: + if (nexpr != 0) + call error(13, + "String value only allow as first term in ksection") + + call strcpy (outstr, extname, LEN_CARD) + nexpr = nexpr + 1 + case TOK_IDENTIFIER: + nident = nident + 1 + call strcpy(outstr, identif, LEN_CARD] + call strlwr(outstr) + lex_type = mef_klex (outstr) + # See if it is a reserved keyword. + jp = ip + # look for =, + or - + if (lex_type > 0) { + # Now see if of the type lex= or lex+/- + if (ctotok (ksection, ip, outstr, LEN_CARD) == + TOK_OPERATOR) { + if (outstr[1] == '=' ) { + token = ctotok (ksection, ip, outstr, LEN_CARD) + if (token != TOK_IDENTIFIER && + token != TOK_STRING && + token != TOK_NUMBER) + call error(13, + "syntax error in kernel section") + else + call mef_kvalue(outstr, lex_type, + extname, extver) + } else + ip = jp + } + } else { + if (nexpr == 0) + call strcpy (identif, extname, LEN_CARD) + else { + call error(13, + "String value only allow as first term in ksection") + } + } + nexpr = nexpr + 1 + default: + call error (13, "Syntax error in ksection") + } + } +end + + +# MEF_KLEX -- Returns the lexival value of a parameter in string. + +int procedure mef_klex (outstr) + +char outstr[ARB] #I string + +int len, strlen(), strncmp() +char tmp[LEN_CARD] + +begin + len = strlen(outstr) + # See if it is extname or extversion + if (strncmp (outstr, "ext", 3) == 0 && len < 8 ) { + if (len == 3) + call error(13, "'ext' is ambiguous in ksection") + call strcpy ("name", tmp, 4) + if (strncmp(outstr[4], tmp, len-3) == 0) + return (KS_EXTNAME) + else { + call strcpy ("ver", tmp, 3) + if (strncmp(outstr[4], tmp, len-3) == 0) + return (KS_EXTVER) + } + } + + return (0) # Is a value + +end + + +define ERROR -2 +# MEF_KVALUE -- Get the value from a string of extname and extver. + +procedure mef_kvalue(outstr, lex_type, extname, extver) + +char outstr[ARB] #I Input string +int lex_type #I Type of value +char extname[ARB] #O Extname +int extver #O Extver + +int ty, lexnum(), ip, ival, ctoi(), nch, junk +int strcmp() + +begin + call strlwr(outstr) + if (strcmp (outstr, "yes") == 0) + ival = YES + else if (strcmp (outstr, "no") == 0) + ival = NO + else + ival = ERROR + + switch (lex_type) { + case KS_EXTNAME: + call strcpy (outstr, extname, LEN_CARD) + case KS_EXTVER: + ip = 1 + ty = lexnum (outstr, ip, nch) + if (ty != LEX_DECIMAL) + call error(13, "Number is not a decimal") + ip = 1 + junk = ctoi(outstr, ip, ival) + extver = ival + default: + call error(13, "Syntax error in ksection") + + } +end diff --git a/pkg/xtools/mef/mefldhdr.x b/pkg/xtools/mef/mefldhdr.x new file mode 100644 index 00000000..c13d7802 --- /dev/null +++ b/pkg/xtools/mef/mefldhdr.x @@ -0,0 +1,118 @@ +include +include +include +include +include + +# MEF_LOAD_HEADER -- Load a FITS header from a file descriptor into a +# spool file. + +int procedure mef_load_header (mef, spool, group) + +pointer mef #I FITS descriptor +int spool #I spool output file descriptor +int group #I Currrent group + +pointer lbuf, sp, fb +int nchars, index, ncards, pcount, in +int mef_read_card(), mef_kctype() +int note() + +errchk mef_read_card +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + call salloc (fb, FITS_BLOCK_BYTES, TY_CHAR) + + MEF_EXTNAME(mef) = EOS + MEF_EXTVER(mef) = INDEFL + + in = MEF_FD(mef) + MEF_HOFF(mef) = note(in) + + # Read successive lines of the FITS header. + pcount = 0 + ncards = 0 + repeat { + # Get the next input line. + nchars = mef_read_card (in, Memc[fb], Memc[lbuf], ncards) + if (nchars == EOF) { + call close (spool) + return (EOF) + } + ncards = ncards + 1 + # A FITS header card already has 80 chars, just add the newline. + Memc[lbuf+LEN_CARD] = '\n' + Memc[lbuf+LEN_CARD+1] = EOS + call putline (spool, Memc[lbuf]) + + # Process the header card. + switch (mef_kctype (Memc[lbuf], index)) { + case END: + MEF_HSIZE(mef) = ncards*LEN_CARDNL + break + case SIMPLE: + call strcpy ("SIMPLE", MEF_EXTTYPE(mef), SZ_EXTTYPE) + case XTENSION: + call mef_gvalt (Memc[lbuf], MEF_EXTTYPE(mef), SZ_EXTTYPE) + case EXTNAME: + call mef_gvalt (Memc[lbuf], MEF_EXTNAME(mef), LEN_CARD) + case EXTVER: + call mef_gvali (Memc[lbuf], MEF_EXTVER(mef)) + case PCOUNT: + call mef_gvali (Memc[lbuf], pcount) + MEF_PCOUNT(mef) = pcount + case BITPIX: + call mef_gvali (Memc[lbuf], MEF_BITPIX(mef)) + case NAXIS: + call mef_gvali (Memc[lbuf], MEF_NDIM(mef)) + case NAXISN: + call mef_gvali (Memc[lbuf], MEF_NAXIS(mef,index)) + case OBJECT: + call mef_gvalt (Memc[lbuf], MEF_OBJECT(mef), MEF_SZVALSTR) + default: + if (ncards == 1) { + call sprintf(Memc[lbuf], SZ_LINE, + "Header does not start with SIMPLE nor XTENSION: %s[%d]") + call pargstr(MEF_FNAME(mef)) + call pargi(group) + call error (13, Memc[lbuf]) + } + } + } + + call sfree (sp) + return (OK) +end + + +# MEF_GET_CARD -- Read a FITS header card. + +int procedure mef_read_card (fd, ibuf, obuf, ncards) + +int fd #I Input file descriptor +char ibuf[ARB] #I input buffer +char obuf[ARB] #O Output buffer +int ncards #I ncards read so far + +int ip, nchars_read +int read() +errchk read + +begin + # We read one FITS block first, read card from it until 36 + # cards have been processed, where we read again. + + if (mod (ncards, 36) == 0) { + nchars_read = read (fd, ibuf, FITS_BLKSZ_CHAR) + if (nchars_read == EOF) + return (EOF) + call miiupk (ibuf, ibuf, FITS_BLOCK_BYTES, MII_BYTE, TY_CHAR) + ip = 1 + } + + call amovc (ibuf[ip], obuf, LEN_CARD) + ip = ip + LEN_CARD + + return (LEN_CARD) +end diff --git a/pkg/xtools/mef/mefopen.x b/pkg/xtools/mef/mefopen.x new file mode 100644 index 00000000..a7a6529d --- /dev/null +++ b/pkg/xtools/mef/mefopen.x @@ -0,0 +1,93 @@ +include + +# MEFOPEN --- Open a FITS extension, it can be the Primary or extension +# unit, file.fits[0] for the PU or file.fits[extn] for the +# Extension Unit. +# +# filename.ext[abs#][extname,extver] +# +# The absolute extension number (abs#) convention is zero for +# the Primary Unit. +# + + +# MEF_OPEN -- Open a FITS Unit from a file and returns its characteristics. + +pointer procedure mef_open (fitsfile, acmode, oldp) + +char fitsfile[ARB] #I Input FITS filename +int acmode #I access mode +pointer oldp #I Old Fits pointer or header size + +pointer sp, ksec, section, mef +int group, clsize, open() + +begin + call smark (sp) + call salloc (ksec, LEN_CARD, TY_CHAR) + call salloc (section, LEN_CARD, TY_CHAR) + + call calloc (mef, LEN_MEF, TY_STRUCT) + + MEF_ACMODE(mef) = acmode + + # Get filename components + call imparse (fitsfile, MEF_FNAME(mef), SZ_FNAME, Memc[ksec], + LEN_CARD, Memc[section], LEN_CARD, group, clsize) + + # Check if file has an extension and exists. + call mef_file_access (MEF_FNAME(mef), acmode) + + if (Memc[section] != EOS) + call error(13, "mefopen: Image sections not allowed") + + MEF_FD(mef) = open (MEF_FNAME(mef), acmode, BINARY_FILE) + MEF_ENUMBER(mef) = group + MEF_CGROUP(mef) = -1 + MEF_KEEPXT(mef) = NO + + call sfree (sp) + return(mef) +end + + +# MEF_FILE_ACCESS -- Check that file exists if READ* mode is given. Mainly we +# want to check if there is an extension 'fits'. If file was given with no +# extension, append .fits and see if exists. + +procedure mef_file_access (fname, acmode) + +char fname[ARB] +int acmode + +pointer sp, fext, fn +int len, fnextn(), access(), strncmp() +begin + if (acmode == NEW_FILE || acmode == NEW_COPY) + return + + call smark (sp) + call salloc (fext, SZ_FNAME, TY_CHAR) + call salloc (fn, SZ_FNAME, TY_CHAR) + + call strcpy (fname, Memc[fn], SZ_FNAME) + + len = fnextn (Memc[fn], Memc[fext], SZ_FNAME) + + if (strncmp("fits", Memc[fext], 4) == 0) + return + + # See if file exists with no extension + if (access(fname, 0, 0) == YES) + return + else { + call strcat( ".fits", Memc[fn], SZ_FNAME) + if (access(Memc[fn], 0, 0) == YES) { + call strcpy (Memc[fn], fname, SZ_FNAME) + return + } + } + + call sfree(sp) + +end diff --git a/pkg/xtools/mef/mefrdhdr.x b/pkg/xtools/mef/mefrdhdr.x new file mode 100644 index 00000000..a8ac45e8 --- /dev/null +++ b/pkg/xtools/mef/mefrdhdr.x @@ -0,0 +1,397 @@ +include +include +include +include +include + +# MEFRDHR.X -- Routines to read FITS header units. +# +# eof|stat = mef_rdhdr (mef, group, extname, extver) +# mef_skip_data_unit (mef) +# totpix = mef_totpix (mef) +# eof|stat = mef_rdhdr_gn (mef,gn) +# eof|stat = mef_rdhdr_exnv (mef,extname, extver) + + +# MEF_RDHR -- Read FITS header on a mef file that matches EXTNAME/EXTVER or +# GROUP number. If both are specified, the former takes procedence. + +int procedure mef_rdhdr (mef, group, extname, extver) + +pointer mef #I Mef descriptor +int group #I Group number to read +char extname[ARB] #I Extname to read +int extver #I Extver to read + +int open(),in, cur_extn, note(), gnum +int spool +bool extnv, read_next_group +int mef_load_header(), mef_pixtype() +bool mef_cmp_extnv +errchk open, read, mef_load_header + +begin + if (group == MEF_CGROUP(mef)) + return (group) + + gnum = group + if (MEF_FD(mef) == NULL) { + MEF_FD(mef) = open (MEF_FNAME(mef), READ_ONLY, BINARY_FILE) + MEF_ENUMBER(mef) = -1 + MEF_CGROUP(mef) = -1 + } + MEF_SKDATA(mef) = NO + + in = MEF_FD(mef) + + extnv = extname[1] != EOS || extver != INDEFL + spool = open ("spool", NEW_FILE, SPOOL_FILE) + + if (gnum == -1 || extnv) + gnum = 0 + + cur_extn = MEF_CGROUP(mef) + read_next_group = true + + repeat { + # If we need to read the next group + if (read_next_group) { + + cur_extn = cur_extn+1 + + # See if this extension contains the correct + # extname/extver values. + + call fseti (spool, F_CANCEL, YES) + if (mef_load_header (mef, spool, cur_extn) == EOF) { + call close (spool) + return (EOF) + } + + # We read the header already, marked the spot. + MEF_POFF(mef) = note(in) + + if (extnv) { + read_next_group = mef_cmp_extnv (mef, extname, extver) + } else { + if (gnum == cur_extn) + read_next_group = false + } + call mef_skip_data_unit (mef) + next + + } else { # This is the group we want + if (MEF_HDRP(mef) != NULL) + call mfree (MEF_HDRP(mef), TY_CHAR) + + call mef_cp_spool (spool, mef) + MEF_CGROUP(mef) = cur_extn + + # To indicate that data has been skipped. + MEF_SKDATA(mef) = YES + break + } + } + call close (spool) + MEF_DATATYPE(mef) = mef_pixtype(mef) + return (cur_extn) +end + +int procedure mef_pixtype (mef) +pointer mef, hdrp +bool bfloat, lscale, lzero +bool fxf_fpl_equald() +int i, impixtype, ctod(), ip +double bscale, bzero +char sval[LEN_CARD] + +begin + hdrp= MEF_HDRP(mef) + bscale = 1.0d0 + ip=1 + ifnoerr (call mef_findkw (hdrp, "BSCALE", sval)) + i = ctod(sval,ip,bscale) + bzero = 0.0d0 + ip=1 + ifnoerr (call mef_findkw (hdrp, "BZERO", sval)) + i = ctod(sval,ip,bzero) + + lscale = fxf_fpl_equald (1.0d0, bscale, 1) + lzero = fxf_fpl_equald (0.0d0, bzero, 1) + + # Determine if scaling is necessary. + bfloat = (!lscale || !lzero) + + switch (MEF_BITPIX(mef)) { + case 8: + if (bfloat) + impixtype = TY_REAL + else + impixtype = TY_SHORT # convert from byte to short + case 16: + if (bfloat) { + impixtype = TY_REAL + } else + impixtype = TY_SHORT + + if (lscale && fxf_fpl_equald (32768.0d0, bzero, 4)) { + impixtype = TY_USHORT + } + case 32: + if (bfloat) + impixtype = TY_REAL + else + impixtype = TY_INT + case -32: + impixtype = TY_REAL + case -64: + impixtype = TY_DOUBLE + default: + impixtype = ERR + } + + return(impixtype) + +end + +# MEF_CMP_EXTNV -- Compare the EXTNAME and EXTVER header values with the +# ones passed as arguments. Return false if matched. + +bool procedure mef_cmp_extnv (mef, extname, extver) +pointer mef +char extname[ARB] #I extname value +int extver #I extver value + +int mef_strcmp_lwr() +bool bxtn, bxtv, bval, bxtn_eq, bxtv_eq + +begin + bxtn = extname[1] != EOS + bxtv = extver != INDEFL + + if (bxtn) + bxtn_eq = (mef_strcmp_lwr(MEF_EXTNAME(mef), extname) == 0) + if (bxtv) + bxtv_eq = (MEF_EXTVER(mef) == extver) + + if (bxtn && bxtv) + # Both EXTNAME and EXTVER are defined. + bval = bxtn_eq && bxtv_eq + else if (bxtn && !bxtv) + # Only EXTNAME is defined. + bval = bxtn_eq + else if (!bxtn && bxtv) + # Only EXTVER is defined. + bval = bxtv_eq + else + bval = false + + return (!bval) +end + +# MEF_SKIP_DATA_UNIT -- Skip data unit. The file is already position at the +# end of the last header block. + +procedure mef_skip_data_unit (mef) + +pointer mef #I Input mef descriptor + +int in, ndim, off, note(), mef_totpix() +errchk seek + +begin + # See if data portion has already been skipped. + if (MEF_SKDATA(mef) == YES) + return + + in = MEF_FD(mef) + ndim = MEF_NDIM (mef) + if (ndim > 0 || MEF_PCOUNT(mef) > 0) { + # Skip to the beginning of next extension + off = note(in) + if (off == EOF) + return + off = off + mef_totpix(mef) + call seek (in, off) + } +end + + +# MEF_TOTPIX -- Returns the number of pixels in the data area in units +# of chars. + +int procedure mef_totpix (mef) + +pointer mef #I Mef descriptor + +int ndim, totpix, i, bitpix + +begin + ndim = MEF_NDIM (mef) + if (ndim == 0 && MEF_PCOUNT(mef) <= 0) + return (0) + + if (ndim == 0) + totpix = 0 + else { + totpix = MEF_NAXIS(mef,1) + do i = 2, ndim + totpix = totpix * MEF_NAXIS(mef,i) + } + bitpix = abs(MEF_BITPIX(mef)) + + # If PCOUNT is not zero, add it to totpix + totpix = MEF_PCOUNT(mef) + totpix + + if (bitpix <= NBITS_BYTE) + totpix = (totpix + 1) / SZB_CHAR + else + totpix = totpix * (bitpix / (SZB_CHAR * NBITS_BYTE)) + + # Set the number of characters in multiple of 1440. + totpix = ((totpix + 1439)/1440) * 1440 + return (totpix) +end + + +# MEF_STRCMP_LWR -- Compare 2 strings in lower case + +int procedure mef_strcmp_lwr (s1, s2) + +char s1[ARB], s2[ARB] + +pointer sp, l1, l2 +int strcmp(), istat + +begin + call smark(sp) + call salloc (l1, SZ_FNAME, TY_CHAR) + call salloc (l2, SZ_FNAME, TY_CHAR) + + call strcpy (s1, Memc[l1], SZ_FNAME) + call strcpy (s2, Memc[l2], SZ_FNAME) + call strlwr(Memc[l1]) + call strlwr(Memc[l2]) + istat = strcmp (Memc[l1], Memc[l2]) + + call sfree(sp) + return (istat) +end + + +# MEF_KCTYPE -- Find the type of card that is based on the keyword name. + +int procedure mef_kctype (card, index) + +char card[ARB] #I FITS card +int index #O index value + +int strncmp() + +begin + if (strncmp (card, "SIMPLE ", 8) == 0) + return (SIMPLE) + if (strncmp (card, "NAXIS", 5) == 0) { + if (card[6] == ' ') { + call mef_gvali (card, index) + return (NAXIS) + } else if (IS_DIGIT(card[6])) { + index = TO_INTEG(card[6]) + return (NAXISN) # NAXISn + } + } + if (strncmp (card, "BITPIX ", 8) == 0) + return (BITPIX) + if (strncmp (card, "EXTNAME ", 8) == 0) + return (EXTNAME) + if (strncmp (card, "EXTVER ", 8) == 0) + return (EXTVER) + if (strncmp (card, "EXTEND ", 8) == 0) + return (EXTEND) + if (strncmp (card, "PCOUNT ", 8) == 0) + return (PCOUNT) + if (strncmp (card, "FILENAME", 8) == 0) + return (FILENAME) + if (strncmp (card, "INHERIT ", 8) == 0) + return (INHERIT) + if (strncmp (card, "GCOUNT ", 8) == 0) + return (GCOUNT) + if (strncmp (card, "OBJECT ", 8) == 0) + return (OBJECT) + if (strncmp (card, "XTENSION", 8) == 0) + return (XTENSION) + if (strncmp (card, "END ", 8) == 0) + return (END) + + return(ERR) +end + + +# MEF_RDHDR_GN -- Read group based on group number + +int procedure mef_rdhdr_gn (mef,gn) + +pointer mef #I mef descriptor +int gn #I group number to read + +char extname[MEF_SZVALSTR] +int extver +int mef_rdhdr() + +errchk mef_rdhdr + +begin + extname[1] =EOS + extver=INDEFL + return (mef_rdhdr (mef, gn, extname, extver)) +end + + +# MEF_RDHDR_EXNV -- Read group based on the Extname and Extver values + +int procedure mef_rdhdr_exnv (mef,extname, extver) + +pointer mef #I, mef descriptor +char extname[ARB] #I, extname value +int extver #I, extver value +int mef_rdhdr() + +errchk mef_rdhdr + +begin + return (mef_rdhdr (mef, 0, extname, extver)) +end + + +# MEF_CP_SPOOL -- + +procedure mef_cp_spool (spool, mef) + +int spool #I spool file descriptor +pointer mef # + +pointer hdr, lbuf, sp +int fitslen, fstatl, user +int stropen(), getline() + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + call seek (spool, BOFL) + fitslen = fstatl (spool, F_FILESIZE) + fitslen = max (fitslen, MEF_HSIZE(mef)) + call malloc (hdr, fitslen, TY_CHAR) + user = stropen (Memc[hdr], fitslen, NEW_FILE) + + # Append the saved FITS cards to saved cache. + while (getline (spool, Memc[lbuf]) != EOF) + call putline (user, Memc[lbuf]) + + call close (user) + call close (spool) + + MEF_HDRP(mef) = hdr + + call sfree(sp) +end diff --git a/pkg/xtools/mef/mefrdhdr.x_save b/pkg/xtools/mef/mefrdhdr.x_save new file mode 100644 index 00000000..a46d5d04 --- /dev/null +++ b/pkg/xtools/mef/mefrdhdr.x_save @@ -0,0 +1,529 @@ +include +include +include +include +include + +# MEFRDHR.X -- Routines to read FITS header units. +# +# mef_rdhdr (mef, group, extname, extver) +# mef_rdblk (in, spp_buf) +# mef_skip_data_unit (mef) +# totpix = mef_totpix (mef) +# mef_rd2end (mef, read_next_group) +# mef_rdhdr_gn (mef,gn) +# mef_rdhdr_exnv (mef,extname, extver) + + +# MEF_RDHR -- Read FITS header on a mef file that matches EXTNAME/EXTVER or +# GROUP number. If both are specified, the former takes procedence. + +procedure mef_rdhdr (mef, group, extname, extver) + +pointer mef #I Mef descriptor +int group #I Group number to read +char extname[ARB] #I Extname to read +int extver #I Extver to read + +int open(),in, cur_extn, note(), gnum +int spool +char spp_buf[FITS_BLKSZ_NL] +bool extnv, end_card, read_next_group, mef_rd1st() +bool mef_cmp_extnv +errchk open, read, mef_rd1st, mef_load_header + +begin + if (group == MEF_CGROUP(mef)) + return + + gnum = group + if (MEF_FD(mef) == NULL) { + MEF_FD(mef) = open (MEF_FNAME(mef), READ_ONLY, BINARY_FILE) + MEF_ENUMBER(mef) = -1 + MEF_CGROUP(mef) = -1 + } + MEF_SKDATA(mef) = NO + + in = MEF_FD(mef) + + extnv = extname[1] != EOS || extver != INDEFL + if (extnv) + spool = open ("spool", NEW_FILE, SPOOL_FILE) + + if (gnum == -1 || extnv) + gnum = 0 +# else if (gnum != -1 && extnv) +# gnum = -1 # EXTNAME/EXTVER takes precedence + + cur_extn = MEF_CGROUP(mef) +# if (cur_extn < 0) +# cur_extn = -1 # Ready to read PHU + read_next_group = true + + repeat { + # If we need to read the next group + if (read_next_group) { + # Read 1st block + cur_extn = cur_extn+1 + + # See if this extension contains the correct + # extname/extver values. + + if (extnv) { + end_card = true + # We are not sure if extname or extver are in the + # 1st block. + call fseti (spool, F_CANCEL, YES) + call mef_load_header (mef, spool) +# iferr (call mef_load_header (mef, spool)) { +# call erract(EA_WARN) +# } + + read_next_group = mef_cmp_extnv (mef, extname, extver) + MEF_POFF(mef) = note(in) + call mef_skip_data_unit (mef) + next + } else { + end_card = mef_rd1st (mef, spp_buf) + if (gnum == cur_extn) + read_next_group = false + } + + if (read_next_group) { + if (!end_card) + call mef_rd2end (mef, read_next_group) + call mef_skip_data_unit (mef) + } + } else { # This is the group we want + if (MEF_HDRP(mef) != NULL) + call mfree (MEF_HDRP(mef), TY_CHAR) + if (end_card) { + if (extnv) { + call mef_cp_spool (spool, mef) + cur_extn = cur_extn + 1 + } else { + call malloc (MEF_HDRP(mef), MEF_HSIZE(mef)+1, TY_CHAR) + call amovc (spp_buf, Memc[MEF_HDRP(mef)], MEF_HSIZE(mef)) + Memc[MEF_HDRP(mef)+MEF_HSIZE(mef)] = EOS + } + } else { + call malloc (MEF_HDRP(mef), FITS_BLKSZ_NL, TY_CHAR) + call amovc (spp_buf, Memc[MEF_HDRP(mef)], FITS_BLKSZ_NL) + call mef_rd2end (mef, read_next_group) + } + if (!extnv) { + if (MEF_NDIM(mef) != 0 || MEF_PCOUNT(mef) > 0) + MEF_POFF(mef) = note(in) + else + MEF_POFF(mef) = INDEFL + call mef_skip_data_unit (mef) + } + MEF_CGROUP(mef) = cur_extn + + # To indicate that data has been skipped. + MEF_SKDATA(mef) = YES + + return + } + } +end + + +# MEF_RD1ST -- Handle the 1st FITS header block. +# Return true if the END card is in this 1st block. + +bool procedure mef_rd1st (mef, hbuf) + +pointer mef #I Mef descriptor +char hbuf[ARB] #O Buffer containing the first block of a unit + +int in, k, i, index, mef_kctype() +int strncmp(), note() +pointer sp, errmsg + +errchk mef_rdblk + +begin + in = MEF_FD(mef) + + # Read 1st block. + MEF_HOFF(mef) = note(in) + call mef_rdblk (in, hbuf) + + MEF_EXTNAME(mef) = EOS + MEF_EXTVER(mef) = INDEFL + k = 1 + # Verify FITS header + if (strncmp (hbuf[k], "SIMPLE ", 8) != 0 && + strncmp (hbuf[k], "XTENSION", 8) != 0 ) { + call smark (sp) + call salloc (errmsg, SZ_LINE, TY_CHAR) + call sprintf (Memc[errmsg], SZ_LINE, "Extension %s[%d] is not FITS.") + call pargstr(MEF_FNAME(mef)) + call pargi(MEF_CGROUP(mef)) + call error (13, Memc[errmsg]) +# iferr (call error (13, Memc[errmsg])) { +# call sfree (sp) +# call erract (EA_ERROR) +# } + } else { + call mef_gvalt (hbuf[k], MEF_EXTTYPE(mef), MEF_SZVALSTR) + if (strncmp (hbuf[k], "SIMPLE ", 8) == 0) + call strcpy (MEF_FNAME(mef), MEF_EXTTYPE(mef), MEF_SZVALSTR) + } + k = k + LEN_CARDNL + + MEF_PCOUNT(mef) = 0 + + for (i=2; i< 37; i=i+1) { + switch (mef_kctype(hbuf[k], index)) { + case NAXIS: + MEF_NDIM(mef) = index + case NAXISN: + call mef_gvali (hbuf[k], MEF_NAXIS(mef,index)) + case BITPIX: + call mef_gvali (hbuf[k], MEF_BITPIX(mef)) + case EXTNAME: + call mef_gvalt (hbuf[k], MEF_EXTNAME(mef), MEF_SZVALSTR) + case EXTVER: + call mef_gvali (hbuf[k], MEF_EXTVER(mef)) + case PCOUNT: + call mef_gvali (hbuf[k], MEF_PCOUNT(mef)) + case OBJECT: + call mef_gvalt (hbuf[k], MEF_OBJECT(mef), MEF_SZVALSTR) + case END: + MEF_HSIZE(mef) = i*LEN_CARDNL + return(true) + break + default: + ; + } + k = k + LEN_CARDNL + } + return(false) + +end + + +# MEF_RDBLK -- Read one header FITS block from disk and add a newline +# after each fits record (80 chars). + +procedure mef_rdblk (in, spp_buf) + +int in #I File descriptor +char spp_buf[ARB] #O Buffer with header + +char ibuf[FITS_BLKSZ_CHAR] +int nchar, i, read(), k, j +char line[LEN_CARD] + +begin + nchar = read (in, ibuf, FITS_BLKSZ_CHAR) + if (nchar == EOF) + call error(13, "EOF encountered") + + # Unpack the input buffer to spp char with new_line delimited records. + line[LEN_CARDNL] = '\n' + k = 1 + j = 1 + for (i=1; i<37; i=i+1) { + call achtbc(ibuf[k], line, LEN_CARD) + call amovc (line, spp_buf[j], LEN_CARDNL) + k = k + 40 + j = j + LEN_CARDNL + } +end + + +# MEF_CMP_EXTNV -- Compare the EXTNAME and EXTVER header values with the +# ones passed as arguments. Return false if matched. + +bool procedure mef_cmp_extnv (mef, extname, extver) +pointer mef +char extname[ARB] #I extname value +int extver #I extver value + +int mef_strcmp_lwr() +bool bxtn, bxtv, bval, bxtn_eq, bxtv_eq + +begin + bxtn = extname[1] != EOS + bxtv = extver != INDEFL + + if (bxtn) + bxtn_eq = (mef_strcmp_lwr(MEF_EXTNAME(mef), extname) == 0) + if (bxtv) + bxtv_eq = (MEF_EXTVER(mef) == extver) + + if (bxtn && bxtv) + # Both EXTNAME and EXTVER are defined. + bval = bxtn_eq && bxtv_eq + else if (bxtn && !bxtv) + # Only EXTNAME is defined. + bval = bxtn_eq + else if (!bxtn && bxtv) + # Only EXTVER is defined. + bval = bxtv_eq + else + bval = false + + return (!bval) +end + +# MEF_SKIP_DATA_UNIT -- Skip data unit. The file is already position at the +# end of the last header block. + +procedure mef_skip_data_unit (mef) + +pointer mef #I Input mef descriptor + +int in, ndim, off, note(), mef_totpix() +errchk seek + +begin + # See if data portion has already been skipped. + if (MEF_SKDATA(mef) == YES) + return + + in = MEF_FD(mef) + ndim = MEF_NDIM (mef) + if (ndim > 0 || MEF_PCOUNT(mef) > 0) { + # Skip to the beginning of next extension + off = note(in) + if (off == EOF) + return + off = off + mef_totpix(mef) + call seek (in, off) + } +end + + +# MEF_TOTPIX -- Returns the number of pixels in the data area in units +# of chars. + +int procedure mef_totpix (mef) + +pointer mef #I Mef descriptor + +int ndim, totpix, i, bitpix + +begin + ndim = MEF_NDIM (mef) + if (ndim == 0 && MEF_PCOUNT(mef) <= 0) + return (0) + + if (ndim == 0) + totpix = 0 + else { + totpix = MEF_NAXIS(mef,1) + do i = 2, ndim + totpix = totpix * MEF_NAXIS(mef,i) + } + bitpix = abs(MEF_BITPIX(mef)) + + # If PCOUNT is not zero, add it to totpix + totpix = MEF_PCOUNT(mef) + totpix + + if (bitpix <= NBITS_BYTE) + totpix = (totpix + 1) / SZB_CHAR + else + totpix = totpix * (bitpix / (SZB_CHAR * NBITS_BYTE)) + + # Set the number of characters in multiple of 1440. + totpix = ((totpix + 1439)/1440) * 1440 + return (totpix) +end + + +# MEF_RD2END -- Read from block 2 to the end. + +procedure mef_rd2end (mef, read_next_group) + +pointer mef #I mef descriptor +bool read_next_group #I if true, read current header to END + +char hbuf[FITS_BLKSZ_NL] +int in, k,i, nblks, strncmp(), size_last_block, hoffset +errchk mef_rdblk + +begin + in = MEF_FD(mef) + # We need to read the header only. + if (read_next_group) + repeat { + k = 1 + call mef_rdblk (in, hbuf) + for (i=1; i<37; i=i+1) { + if (strncmp (hbuf[k], "END " , 8) == 0) + return + else + k = k + LEN_CARDNL + } + } + + + # This is the requested header, copy to user area. + nblks = 2 + repeat { + k = 1 + call mef_rdblk (in, hbuf) + # Copy the buffer into the user area. + for (i=1; i<37; i=i+1) { + if (strncmp (hbuf[k], "END " , 8) == 0) { + size_last_block = i*LEN_CARDNL + call realloc (MEF_HDRP(mef), FITS_BLKSZ_NL*nblks+1, TY_CHAR) + hoffset = MEF_HDRP(mef)+FITS_BLKSZ_NL*(nblks-1) + call amovc (hbuf, Memc[hoffset], size_last_block) + Memc[hoffset+size_last_block] = EOS + MEF_HSIZE(mef) = (nblks-1)*FITS_BLKSZ_NL + size_last_block + return + } else + k = k + LEN_CARDNL + } + call realloc (MEF_HDRP(mef), FITS_BLKSZ_NL*nblks, TY_CHAR) + hoffset = MEF_HDRP(mef)+FITS_BLKSZ_NL*(nblks-1) + call amovc (hbuf, Memc[hoffset], FITS_BLKSZ_NL) + nblks = nblks + 1 + } +end + + +# MEF_STRCMP_LWR -- Compare 2 strings in lower case + +int procedure mef_strcmp_lwr (s1, s2) + +char s1[ARB], s2[ARB] + +pointer sp, l1, l2 +int strcmp(), istat + +begin + call smark(sp) + call salloc (l1, SZ_FNAME, TY_CHAR) + call salloc (l2, SZ_FNAME, TY_CHAR) + + call strcpy (s1, Memc[l1], SZ_FNAME) + call strcpy (s2, Memc[l2], SZ_FNAME) + call strlwr(Memc[l1]) + call strlwr(Memc[l2]) + istat = strcmp (Memc[l1], Memc[l2]) + + call sfree(sp) + return (istat) +end + + +# MEF_KCTYPE -- Find the type of card that is based on the keyword name. + +int procedure mef_kctype (card, index) + +char card[ARB] #I FITS card +int index #O index value + +int strncmp() + +begin + if (strncmp (card, "SIMPLE ", 8) == 0) + return (SIMPLE) + if (strncmp (card, "NAXIS", 5) == 0) { + if (card[6] == ' ') { + call mef_gvali (card, index) + return (NAXIS) + } else if (IS_DIGIT(card[6])) { + index = TO_INTEG(card[6]) + return (NAXISN) # NAXISn + } + } + if (strncmp (card, "BITPIX ", 8) == 0) + return (BITPIX) + if (strncmp (card, "EXTNAME ", 8) == 0) + return (EXTNAME) + if (strncmp (card, "EXTVER ", 8) == 0) + return (EXTVER) + if (strncmp (card, "EXTEND ", 8) == 0) + return (EXTEND) + if (strncmp (card, "PCOUNT ", 8) == 0) + return (PCOUNT) + if (strncmp (card, "FILENAME", 8) == 0) + return (FILENAME) + if (strncmp (card, "INHERIT ", 8) == 0) + return (INHERIT) + if (strncmp (card, "GCOUNT ", 8) == 0) + return (GCOUNT) + if (strncmp (card, "OBJECT ", 8) == 0) + return (OBJECT) + if (strncmp (card, "XTENSION", 8) == 0) + return (XTENSION) + if (strncmp (card, "END ", 8) == 0) + return (END) + + return(ERR) +end + + +# MEF_RDHDR_GN -- Read group based on group number + +procedure mef_rdhdr_gn (mef,gn) + +pointer mef #I mef descriptor +int gn #I group number to read + +char extname[MEF_SZVALSTR] +int extver + +errchk mef_rdhdr + +begin + extname[1] =EOS + extver=INDEFL + call mef_rdhdr (mef, gn, extname, extver) +end + + +# MEF_RDHDR_EXNV -- Read group based on the Extname and Extver values + +procedure mef_rdhdr_exnv (mef,extname, extver) + +pointer mef #I, mef descriptor +char extname[ARB] #I, extname value +int extver #I, extver value + +errchk mef_rdhdr + +begin + call mef_rdhdr (mef, 0, extname, extver) +end + + +# MEF_CP_SPOOL -- + +procedure mef_cp_spool (spool, mef) + +int spool #I spool file descriptor +pointer mef # + +pointer hdr, lbuf, sp +int fitslen, fstatl, user +int stropen(), getline() + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + call seek (spool, BOFL) + fitslen = fstatl (spool, F_FILESIZE) + fitslen = max (fitslen, MEF_HSIZE(mef)) + call malloc (hdr, fitslen, TY_CHAR) + user = stropen (Memc[hdr], fitslen, NEW_FILE) + + # Append the saved FITS cards to saved cache. + while (getline (spool, Memc[lbuf]) != EOF) + call putline (user, Memc[lbuf]) + + call close (user) + call close (spool) + + MEF_HDRP(mef) = hdr + + call sfree(sp) +end diff --git a/pkg/xtools/mef/mefsetpl.x b/pkg/xtools/mef/mefsetpl.x new file mode 100644 index 00000000..0df45a4a --- /dev/null +++ b/pkg/xtools/mef/mefsetpl.x @@ -0,0 +1,203 @@ +include + +define MEF_PLVERSION MEF_HFLAG +define MEF_PLSIZE MEF_CGROUP + +define DEF_SZBUF 32768 +define INC_SZBUF 16384 +define INC_HDRMEM 8100 +define IDB_RECLEN 80 + +define KW_TITLE "$TITLE = " +define LEN_KWTITLE 9 +define KW_CTIME "$CTIME = " +define LEN_KWCTIME 9 +define KW_MTIME "$MTIME = " +define LEN_KWMTIME 9 +define KW_LIMTIME "$LIMTIME = " +define LEN_KWLIMTIME 11 +define KW_MINPIXVAL "$MINPIXVAL = " +define LEN_KWMINPIXVAL 13 +define KW_MAXPIXVAL "$MAXPIXVAL = " +define LEN_KWMAXPIXVAL 13 + +define SZ_IMTITLE 383 # image title string + +procedure mef_setpl (version, plsize, imhdr, title, ctime, mtime, limtime, + minval, maxval, mef) + +int version #I PL version number +char imhdr[ARB] #I Mask title +char title[ARB] +int plsize #I Mask size of TY_SHORT +int ctime +int mtime +int limtime +real minval +real maxval +pointer mef #I Mef descriptor + +int tlen, i, ch, hdrlen, nchars +pointer sp, tbuf, ip, op, rp, bp, hd +int strncmp(), ctol(), ctor(), strlen() +errchk realloc + +begin + MEF_PLVERSION(mef) = version + MEF_PLSIZE(mef) = plsize + tlen= strlen(imhdr) + + call smark (sp) + call salloc (tbuf, SZ_IMTITLE, TY_CHAR) + call salloc (bp, tlen, TY_CHAR) + + call strcpy (imhdr, Memc[bp], tlen) + + + # Get the image title string. + for (ip = bp; Memc[ip] != EOS;) { + if (Memc[ip] == '$') { + if (strncmp (Memc[ip], KW_TITLE, LEN_KWTITLE) == 0) { + # Advance to first character of quoted string. + ip = ip + LEN_KWTITLE + while (Memc[ip] != EOS && Memc[ip] != '"') + ip = ip + 1 + if (Memc[ip] == '"') + ip = ip + 1 + + # Extract the string. + op = tbuf + while (Memc[ip] != EOS && Memc[ip] != '"') { + if (Memc[ip] == '\\' && Memc[ip+1] == '"') + ip = ip + 1 + Memc[op] = Memc[ip] + op = min (tbuf + SZ_IMTITLE, op + 1) + ip = ip + 1 + } + + # Store in image descriptor. + Memc[op] = EOS + call strcpy (Memc[tbuf], title, SZ_IMTITLE) + + # Advance to next line. + while (Memc[ip] != EOS && Memc[ip] != '\n') + ip = ip + 1 + if (Memc[ip] == '\n') + ip = ip + 1 + + } else if (strncmp (Memc[ip], KW_CTIME, LEN_KWCTIME) == 0) { + # Decode the create time. + ip = ip + LEN_KWCTIME + rp = 1 + if (ctol (Memc[ip], rp, ctime) <= 0) + ctime = 0 + ip = ip + rp - 1 + + # Advance to next line. + while (Memc[ip] != EOS && Memc[ip] != '\n') + ip = ip + 1 + if (Memc[ip] == '\n') + ip = ip + 1 + + } else if (strncmp (Memc[ip], KW_MTIME, LEN_KWMTIME) == 0) { + # Decode the modify time. + ip = ip + LEN_KWMTIME + rp = 1 + if (ctol (Memc[ip], rp, mtime) <= 0) + mtime = 0 + ip = ip + rp - 1 + + # Advance to next line. + while (Memc[ip] != EOS && Memc[ip] != '\n') + ip = ip + 1 + if (Memc[ip] == '\n') + ip = ip + 1 + + } else if (strncmp (Memc[ip], KW_LIMTIME, LEN_KWLIMTIME) == 0) { + # Decode the limits time. + ip = ip + LEN_KWLIMTIME + rp = 1 + if (ctol (Memc[ip], rp, limtime) <= 0) + limtime = 0 + ip = ip + rp - 1 + + # Advance to next line. + while (Memc[ip] != EOS && Memc[ip] != '\n') + ip = ip + 1 + if (Memc[ip] == '\n') + ip = ip + 1 + + } else if (strncmp(Memc[ip],KW_MINPIXVAL,LEN_KWMINPIXVAL)==0) { + # Decode the minimum pixel value. + ip = ip + LEN_KWMINPIXVAL + rp = 1 + if (ctor (Memc[ip], rp, minval) <= 0) + minval = 0.0 + ip = ip + rp - 1 + + # Advance to next line. + while (Memc[ip] != EOS && Memc[ip] != '\n') + ip = ip + 1 + if (Memc[ip] == '\n') + ip = ip + 1 + + } else if (strncmp(Memc[ip],KW_MAXPIXVAL,LEN_KWMAXPIXVAL)==0) { + # Decode the maximum pixel value. + ip = ip + LEN_KWMAXPIXVAL + rp = 1 + if (ctor (Memc[ip], rp, maxval) <= 0) + maxval = 0.0 + ip = ip + rp - 1 + + # Advance to next line. + while (Memc[ip] != EOS && Memc[ip] != '\n') + ip = ip + 1 + if (Memc[ip] == '\n') + ip = ip + 1 + } + } else + break + } + + hdrlen = tlen*2 + call malloc (hd, hdrlen, TY_CHAR) + op = hd + + while (Memc[ip] != EOS) { + rp = op + + nchars = rp - hd + if (nchars + IDB_RECLEN + 2 > hdrlen) { + hdrlen = hdrlen + INC_HDRMEM + call realloc (hd, hdrlen, TY_CHAR) + op = hd + nchars + } + # Copy the saved card, leave IP positioned to past newline. + do i = 1, IDB_RECLEN { + ch = Memc[ip] + if (ch != EOS) + ip = ip + 1 + if (ch == '\n') + break + Memc[op] = ch + op = op + 1 + } + + # Blank fill the card. + while (op - rp < IDB_RECLEN) { + Memc[op] = ' ' + op = op + 1 + } + + # Add newline termination. + Memc[op] = '\n'; op = op + 1 + } + + Memc[op] = EOS + + MEF_HDRP(mef) = hd + MEF_HSIZE(mef) = strlen(Memc[hd]) + + call sfree (sp) +end + diff --git a/pkg/xtools/mef/mefwrhdr.x b/pkg/xtools/mef/mefwrhdr.x new file mode 100644 index 00000000..90ec337e --- /dev/null +++ b/pkg/xtools/mef/mefwrhdr.x @@ -0,0 +1,212 @@ +include +include + +# MEF_WRHDR -- Append the header from an input PHU or extension to output file. + +procedure mef_wrhdr (mefi, mefo, in_phdu) + +pointer mefi #I input mef descriptor +pointer mefo #I output mef descriptor +bool in_phdu #I true if input header is Primary Header Unit. + +pointer hb, sp, ln +int output_lines, out, offset +int i, index, naxis, mef_kctype(), strncmp(), note() +bool endk, new_outf +errchk open, fcopyo + +define nextb_ 99 + +begin + call smark (sp) + call salloc (ln, LEN_CARDNL, TY_CHAR) + + # At this point the input first header has been read + + hb = MEF_HDRP(mefi) + if (Memc[hb] == NULL) + call error(13,"mef_wrhdr: input header buffer is empty") + + out = MEF_FD(mefo) + + new_outf = false + if (MEF_ACMODE(mefo) == NEW_IMAGE) + new_outf = true + + output_lines = 0 + endk = false + + # If we want to copy the header with no modification + if (MEF_KEEPXT(mefo) == YES) { + for (i=1; i<37; i=i+1) { + switch (mef_kctype(Memc[hb], index)) { + case END: + call mef_pakwr (out, Memc[hb]) + endk = true + output_lines = i + break + default: + call mef_pakwr (out, Memc[hb]) + hb = hb + LEN_CARDNL + } + } + goto nextb_ + } + + # Check for 1st card + if (strncmp (Memc[hb], "SIMPLE ", 8) == 0) { + # Append extension to existing file + if (!new_outf) { + call mef_encodec ("XTENSION", "IMAGE", 5, Memc[ln], + "Image extension") + call mef_pakwr (out, Memc[ln]) + } else + call mef_pakwr (out, Memc[hb]) + } else if (strncmp (Memc[hb], "XTENSION", 8) == 0 ) { + if (new_outf) { + # Create a PHU + # Must create a dummy header if input extension is not image + if (strncmp (MEF_EXTTYPE(mefi), "IMAGE", 5) != 0) { + Memc[ln] = EOS + call mef_dummyhdr (out, Memc[ln]) + new_outf = false + call mef_pakwr (out, Memc[hb]) + } else { + call mef_encodeb ("SIMPLE", YES, Memc[ln], + "Standard FITS format") + call mef_pakwr (out, Memc[ln]) + } + } else + call mef_pakwr (out, Memc[hb]) + } else { + # Is the wrong kind of header +# call eprintf ("File %s is not FITS\n") +# call erract (EA_FATAL) + call sprintf (Memc[ln],LEN_CARD, "File %s is not FITS") + call pargstr(MEF_FNAME(mefi)) + call error(13, Memc[ln]) + } + hb = hb + LEN_CARDNL + + for (i=2; i<37; i=i+1) { + switch (mef_kctype(Memc[hb], index)) { + case BITPIX: + # Get to calculate totpix value + call mef_gvali (Memc[hb], MEF_BITPIX(mefi)) + case NAXIS: + naxis = index + MEF_NDIM(mefi) = index + if (in_phdu && !new_outf && naxis == 0) { + call mef_pakwr (out, Memc[hb]) + call mef_wrpgcount (out) + output_lines = output_lines + 2 + hb = hb + LEN_CARDNL + next + } + case NAXISN: + call mef_gvali (Memc[hb], MEF_NAXIS(mefi,index)) + call mef_pakwr (out, Memc[hb]) + if (index == naxis) { + if (in_phdu && !new_outf ) { + # We are writing from a phu to ehu. + # 2 new cards PCOUNT and GCOUNT + + call mef_wrpgcount (out) + output_lines = output_lines + 2 + } + if (!in_phdu && new_outf) { + # We are writing from a ehu to a phu + call mef_encodeb ("EXTEND", YES, Memc[ln], + "There may be extensions") + call mef_pakwr (out, Memc[ln]) + output_lines = output_lines + 1 + } + } + hb = hb + LEN_CARDNL + next + case EXTEND, FILENAME: + if (!new_outf) { + # Do not put these cards when going to an ehu + output_lines = output_lines - 1 + hb = hb + LEN_CARDNL + next + } + case INHERIT: + # Eliminate INHERIT keyword from an input IMAGE extension + # when creating a new output file. If file already exists + # then pass the card along. + + if (new_outf) { + output_lines = output_lines - 1 + hb = hb + LEN_CARDNL + next + } + case PCOUNT,GCOUNT,EXTNAME,EXTVER: + # Do not put these cards into PHU + if (new_outf) { + output_lines = output_lines - 1 + hb = hb + LEN_CARDNL + next + } + case END: + call mef_pakwr (out, Memc[hb]) + endk = true + output_lines = i + output_lines + break + default: + ; + } + call mef_pakwr (out, Memc[hb]) + hb = hb + LEN_CARDNL + + } # end for loop + +nextb_ + # See if we need to keep reading header + # + if (!endk) + repeat { + for (i=1; i<37; i=i+1) { + if (strncmp (Memc[hb], "END ", 8) == 0) { + call mef_pakwr (out, Memc[hb]) + endk = true + output_lines = i + output_lines + break + } + call mef_pakwr (out, Memc[hb]) + hb = hb + LEN_CARDNL + } + if (endk) break + + } #end repeat + + offset = note(out)-1 # to base zero + call mef_padfile (out, offset) + call flush(out) + + call sfree(sp) +end + +procedure mef_padfile (fd, offset) + +int fd # file descriptor +int offset # file position in chars + +int pad, nlines,i +char card[LEN_CARDNL] + +begin + i = mod(offset, 1440) + if (i == 0) return + + pad = 1440 - i + nlines = pad/40 + + do i =1, 80 + card[i] = ' ' + call achtcb (card, card, 80) + + for(i=1; i<=nlines; i=i+1) + call write(fd, card, 40) + +end diff --git a/pkg/xtools/mef/mefwrhdr.x_save b/pkg/xtools/mef/mefwrhdr.x_save new file mode 100644 index 00000000..ef1c332b --- /dev/null +++ b/pkg/xtools/mef/mefwrhdr.x_save @@ -0,0 +1,185 @@ +include +include + +# MEF_WRHDR -- Append the header from an input PHU or extension to output file. + +procedure mef_wrhdr (mefi, mefo, in_phdu) + +pointer mefi #I input mef descriptor +pointer mefo #I output mef descriptor +bool in_phdu #I true if input header is Primary Header Unit. + +pointer hb, sp, ln +int output_lines, out +int i, index, naxis, mef_kctype(), strncmp() +bool endk, new_outf +errchk open, fcopyo + +define nextb_ 99 + +begin + call smark (sp) + call salloc (ln, LEN_CARDNL, TY_CHAR) + + # At this point the input first header has been read + + hb = MEF_HDRP(mefi) + if (Memc[hb] == NULL) + call error(13,"mef_wrhdr: input header buffer is empty") + + out = MEF_FD(mefo) + + new_outf = false + if (MEF_ACMODE(mefo) == NEW_IMAGE) + new_outf = true + + output_lines = 0 + endk = false + + # If we want to copy the header with no modification + if (MEF_KEEPXT(mefo) == YES) { + for (i=1; i<37; i=i+1) { + switch (mef_kctype(Memc[hb], index)) { + case END: + call mef_pakwr (out, Memc[hb]) + endk = true + output_lines = i + break + default: + call mef_pakwr (out, Memc[hb]) + hb = hb + LEN_CARDNL + } + } + goto nextb_ + } + + # Check for 1st card + if (strncmp (Memc[hb], "SIMPLE ", 8) == 0) { + # Append extension to existing file + if (!new_outf) { + call mef_encodec ("XTENSION", "IMAGE", 5, Memc[ln], + "Image extension") + call mef_pakwr (out, Memc[ln]) + } else + call mef_pakwr (out, Memc[hb]) + } else if (strncmp (Memc[hb], "XTENSION", 8) == 0 ) { + if (new_outf) { + # Create a PHU + # Must create a dummy header if input extension is not image + if (strncmp (MEF_EXTTYPE(mefi), "IMAGE", 5) != 0) { + Memc[ln] = EOS + call mef_dummyhdr (out, Memc[ln]) + new_outf = false + call mef_pakwr (out, Memc[hb]) + } else { + call mef_encodeb ("SIMPLE", YES, Memc[ln], + "Standard FITS format") + call mef_pakwr (out, Memc[ln]) + } + } else + call mef_pakwr (out, Memc[hb]) + } else { + # Is the wrong kind of header +# call eprintf ("File %s is not FITS\n") +# call erract (EA_FATAL) + call sprintf (Memc[ln],LEN_CARD, "File %s is not FITS") + call pargstr(MEF_FNAME(mefi)) + call error(13, Memc[ln]) + } + hb = hb + LEN_CARDNL + + for (i=2; i<37; i=i+1) { + switch (mef_kctype(Memc[hb], index)) { + case BITPIX: + # Get to calculate totpix value + call mef_gvali (Memc[hb], MEF_BITPIX(mefi)) + case NAXIS: + naxis = index + MEF_NDIM(mefi) = index + if (in_phdu && !new_outf && naxis == 0) { + call mef_pakwr (out, Memc[hb]) + call mef_wrpgcount (out) + output_lines = output_lines + 2 + hb = hb + LEN_CARDNL + next + } + case NAXISN: + call mef_gvali (Memc[hb], MEF_NAXIS(mefi,index)) + call mef_pakwr (out, Memc[hb]) + if (index == naxis) { + if (in_phdu && !new_outf ) { + # We are writing from a phu to ehu. + # 2 new cards PCOUNT and GCOUNT + + call mef_wrpgcount (out) + output_lines = output_lines + 2 + } + if (!in_phdu && new_outf) { + # We are writing from a ehu to a phu + call mef_encodeb ("EXTEND", YES, Memc[ln], + "There may be extensions") + call mef_pakwr (out, Memc[ln]) + output_lines = output_lines + 1 + } + } + hb = hb + LEN_CARDNL + next + case EXTEND, FILENAME: + if (!new_outf) { + # Do not put these cards when going to an ehu + output_lines = output_lines - 1 + hb = hb + LEN_CARDNL + next + } + case INHERIT: + # Eliminate INHERIT keyword from an input IMAGE extension + # when creating a new output file. If file already exists + # then pass the card along. + + if (new_outf) { + output_lines = output_lines - 1 + hb = hb + LEN_CARDNL + next + } + case PCOUNT,GCOUNT,EXTNAME,EXTVER: + # Do not put these cards into PHU + if (new_outf) { + output_lines = output_lines - 1 + hb = hb + LEN_CARDNL + next + } + case END: + call mef_pakwr (out, Memc[hb]) + endk = true + output_lines = i + output_lines + break + default: + ; + } + call mef_pakwr (out, Memc[hb]) + hb = hb + LEN_CARDNL + + } # end for loop + +nextb_ + # See if we need to keep reading header + # + if (!endk) + repeat { + for (i=1; i<37; i=i+1) { + if (strncmp (Memc[hb], "END ", 8) == 0) { + call mef_pakwr (out, Memc[hb]) + endk = true + output_lines = i + output_lines + break + } + call mef_pakwr (out, Memc[hb]) + hb = hb + LEN_CARDNL + } + if (endk) break + + } #end repeat + call mef_wrblank (out, output_lines) + + call sfree(sp) +end diff --git a/pkg/xtools/mef/mefwrpl.x b/pkg/xtools/mef/mefwrpl.x new file mode 100644 index 00000000..1eef1cc2 --- /dev/null +++ b/pkg/xtools/mef/mefwrpl.x @@ -0,0 +1,213 @@ +include +include + +define MEF_PLSIZE MEF_CGROUP +# MEF_WRPL -- + +procedure mef_wrpl (mef, title, ctime,mtime, limtime, minval, + maxval,plbuf, naxis, axlen) + +char title[ARB] +int ctime, mtime, limtime +real minval, maxval +pointer mef #I input mef descriptor +short plbuf #I Pixel list buffer +int naxis, axlen[ARB] + +pointer sp, ln, mii, hb +char blank[1] +int output_lines, npad, i +int pcount, fd, nlines +bool endk, new_outf +errchk open, fcopyo + +begin + call smark (sp) + call salloc (ln, LEN_CARDNL, TY_CHAR) + + # Output file descriptor + fd = MEF_FD(mef) + + new_outf = false + if (MEF_ACMODE(mef) == NEW_IMAGE) + new_outf = true + + output_lines = 0 + endk = false + + # Create a PHU + if (new_outf) { + # Must create a dummy header if input extension is not image + Memc[ln] = EOS + call mef_dummyhdr (fd, Memc[ln]) + new_outf = false + } + + call mef_wcardc ("XTENSION", "BINTABLE", "Extension type", fd) + call mef_wcardi ("BITPIX", 8, "Default value", fd) + call mef_wcardi ("NAXIS", 2, "Lines and cols", fd) + call mef_wcardi ("NAXIS1", 8, "Nbytes per line", fd) + call mef_wcardi ("NAXIS2", 1, "Nlines", fd) + + # Calculate the number of 2880 bytes block the heap will + # occupy. + + pcount = ((MEF_PLSIZE(mef)+1439)/1440)*2880 + call mef_wcardi ("PCOUNT", pcount, "Heap size in bytes", fd) + call mef_wcardi ("GCOUNT", 1, "1 Group", fd) + call mef_wcardi ("TFIELDS", 1, "1 Column field", fd) + call sprintf (Memc[ln], LEN_CARD, "PI(%d)") + call pargi(MEF_PLSIZE(mef)) + call mef_wcardc ("TFORM1", Memc[ln], "Variable word array", fd) + call mef_wcardb ("INHERIT", NO, "No Inherit", fd) + call mef_wcardc ("ORIGIN", FITS_ORIGIN, "FITS file originator", fd) + call mef_wcardc ("EXTNAME", MEF_EXTNAME(mef), "", fd) + call mef_wcardi ("EXTVER", MEF_EXTVER(mef), "", fd) + call mef_wcardi ("CTIME", ctime, "", fd) + call mef_wcardi ("MTIME", mtime, "", fd) + call mef_wcardi ("LIMTIME", limtime, "", fd) + call mef_wcardr ("DATAMIN", minval, "", fd) + call mef_wcardr ("DATAMAX", maxval, "", fd) + call mef_wcardc ("OBJECT", title, "", fd) + + call mef_wcardb ("CMPIMAGE", YES, "Is a compressed image", fd) + call mef_wcardc ("CMPTYPE", "PLIO_1", "IRAF image masks", fd) + call mef_wcardi ("CBITPIX", 32, "BITPIX for uncompressed image", fd) + call mef_wcardi ("CNAXIS", naxis, "NAXIS for uncompressed image", fd) + do i = 1, naxis { + call sprintf (Memc[ln], LEN_CARD, "NAXIS%d") + call pargi(i) + call mef_wcardi ("CNAXIS", axlen[i], "axis length", fd) + } + + hb = MEF_HDRP(mef) + output_lines = 23 + nlines = MEF_HSIZE(mef) / LEN_CARDNL + + for (i=1; i<= nlines; i=i+1) { + call mef_pakwr (fd, Memc[hb]) + hb = hb + LEN_CARDNL + } + + blank[1] = ' ' + call amovkc (blank, Memc[ln], 80) + call strcpy ("END", Memc[ln], 3) + Memc[ln+3] = ' ' # Clear EOS mark + call mef_pakwr (fd, Memc[ln]) + + output_lines = output_lines + nlines + 1 + naxis + call mef_wrblank (fd, output_lines) + + call salloc (mii, 1400, TY_INT) + + # Now write 2 integers as table data (nelem,offset) + Memi[mii] = MEF_PLSIZE(mef) # Number of words in pl buff (2bytes) + Memi[mii+1] = 0 # Offset from start of heap + + npad = 1438 + call amovki (0, Memi[mii+2], npad) + call write (fd, Memi[mii], 1440) + + # Write mask in heap area + call write (fd, plbuf, MEF_PLSIZE(mef)*SZ_SHORT) + + # Pad to 1440 characters block in case we want to append another + # extension + + npad = 1440 - mod (MEF_PLSIZE(mef), 1440) + + call amovki (0, Memi[mii], npad) + call write (fd, Memi[mii], npad) + + + call sfree(sp) +end + +procedure mef_wcardi (kname, kvalue, kcomm, fd) + +char kname[ARB] #I Keyword name +int kvalue #I Keyword value +char kcomm[ARB] #I Card comment +int fd #I file descriptor + +pointer sp, ln + +begin + + call smark (sp) + call salloc (ln, LEN_CARDNL, TY_CHAR) + + call mef_encodei (kname, kvalue, Memc[ln], kcomm) + call mef_pakwr (fd, Memc[ln]) + + call sfree (sp) + +end + + +procedure mef_wcardc (kname, kvalue, kcomm, fd) + +char kname[ARB] #I Keyword name +char kvalue[ARB] #I Keyword value +char kcomm[ARB] #I Card comment +int fd #I file descriptor + +pointer sp, ln +int slen, strlen() + +begin + + call smark (sp) + call salloc (ln, LEN_CARDNL, TY_CHAR) + + slen = strlen(kvalue) + call mef_encodec (kname, kvalue, slen, Memc[ln], kcomm) + call mef_pakwr (fd, Memc[ln]) + + call sfree(sp) + +end + + +procedure mef_wcardb (kname, kvalue, kcomm, fd) + +char kname[ARB] #I Keyword name +int kvalue #I Keyword value +char kcomm[ARB] #I Card comment +int fd #I file descriptor + +pointer sp, ln + +begin + + call smark (sp) + call salloc (ln, LEN_CARDNL, TY_CHAR) + + call mef_encodeb (kname, kvalue, Memc[ln], kcomm) + call mef_pakwr (fd, Memc[ln]) + + call sfree(sp) + +end + +procedure mef_wcardr (kname, kvalue, kcomm, fd) + +char kname[ARB] #I Keyword name +real kvalue #I Keyword value +char kcomm[ARB] #I Card comment +int fd #I file descriptor + +pointer sp, ln + +begin + + call smark (sp) + call salloc (ln, LEN_CARDNL, TY_CHAR) + + call mef_encoder (kname, kvalue, Memc[ln], kcomm, 6) + call mef_pakwr (fd, Memc[ln]) + + call sfree(sp) + +end + diff --git a/pkg/xtools/mef/mkpkg b/pkg/xtools/mef/mkpkg new file mode 100644 index 00000000..5a3f358c --- /dev/null +++ b/pkg/xtools/mef/mkpkg @@ -0,0 +1,26 @@ +# MEFLIB + +update: + $checkout libxtools.a lib$ + $update libxtools.a + $checkin libxtools.a lib$ + ; + +libxtools.a: + mefappfile.x + mefclose.x + mefcpextn.x + mefdummyh.x + mefencode.x + mefget.x + mefgnbc.x + mefgval.x + mefkfind.x + mefksection.x + mefldhdr.x + mefopen.x + mefrdhdr.x + mefsetpl.x + mefwrhdr.x + mefwrpl.x + ; -- cgit