fitsutil-2018.07.06/000077500000000000000000000000001332007674300137675ustar00rootroot00000000000000fitsutil-2018.07.06/COPYRIGHT000066400000000000000000000031241332007674300152620ustar00rootroot00000000000000Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. The IRAF software is publicly available, but is NOT in the public domain. The difference is that copyrights granting rights for unrestricted use and redistribution have been placed on all of the software to identify its authors. You are allowed and encouraged to take this software and use it as you wish, subject to the restrictions outlined below. Permission to use, copy, modify, and distribute this software and its documentation is hereby granted without fee, provided that the above copyright notice appear in all copies and that both that copyright notice and this permission notice appear in supporting documentation, and that references to the Association of Universities for Research in Astronomy Inc. (AURA), the National Optical Astronomy Observatories (NOAO), or the Image Reduction and Analysis Facility (IRAF) not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission from NOAO. NOAO makes no representations about the suitability of this software for any purpose. It is provided "as is" without express or implied warranty. NOAO DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL NOAO BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. fitsutil-2018.07.06/README000066400000000000000000000066521332007674300146600ustar00rootroot00000000000000 Installation of the FITSUTIL external package -------------------------------------------------- [1] The package is distributed as a compressed tar archive. % ftp 140.252.1.1 login: anonymous password: [your last name] ftp> cd iraf/extern ftp> get fitsutil.readme ftp> binary ftp> get fitsutil.tar.Z ftp> quit % uncompress fitsutil.tar The readme.fitsutil file contains these instructions. [2] Create a directory to contain the FITSUTIL external package files. This directory should be outside the IRAF directory tree and must be owned by the IRAF account. In the following examples, this root directory is named usr1:[fitsutil] (VMS) or /local/fitsutil/ (UNIX). Make the appropriate file name substitutions for your site. [3] Log in as IRAF and edit the extern.pkg file in the hlib directory to define the package to the CL. From the IRAF account, outside the CL, you can move to this directory with the commands: $ set def irafhlib # VMS example % cd $hlib # UNIX example Define the environment variable fitsutil to be the pathname to the fitsutil root directory. The '$' character must be escaped in the VMS pathname; UNIX pathnames must be terminated with a '/'. Edit extern.pkg to include: reset fitsutil = usr\$1:[fitsutil] # VMS example reset fitsutil = /local/fitsutil/ # UNIX example task fitsutil.pkg = fitsutil$fitsutil.cl Near the end of the hlib$extern.pkg file, update the definition of helpdb so it includes the fitsutil help database, copying the syntax already used in the string. Add this line before the line containing a closing quote: ,fitsutil$lib/helpdb.mip\ [4] Log into the CL from the IRAF account and unpack the archive file. Change directories to the FITSUTIL root directory created above and use 'rtar': cl> cd fitsutil cl> softools cl> rtar -xrf where is the host name of the archive file or the IRAF tape device for tape distributions. On VMS systems, an error message will appear ("Copy 'bin.generic' to './bin fails") which can be ignored. Also on VMS systems, the four bin.'mach' directories created by rtar under [newimred.bin] can be deleted. UNIX sites should leave the symbolic link 'bin' in the FITSUTIL root directory pointing to 'bin.generic' but can delete any of the bin.`mach' directories that won't be used. The archive file can be deleted once the package has been successfully installed. [5] When the archive has been unpacked, build the FITSUTIL package executable. The compilation and linking of the FITSUTIL package is done using the following command: cl> mkpkg -p fitsutil update >& fitsutil.spool & NOTE: On systems that concurrently support different architectures (e.g., Suns, Convex), you must configure the system for the desired architecture before issuing the above command. SUN/IRAF sites must execute a pair of 'mkpkg' commands for each supported architecture type. The Unix environment variable IRAFARCH must be set as well before compiling. For example: # Assuming IRAFARCH is set to ffpa cl> mkpkg -p fitsutil ffpa cl> mkpkg -p fitsutil update >& fitsutil.ffpa & cl> mkpkg -p fitsutil f68881 # Now reset IRAFARCH to f68881 before continuing cl> mkpkg -p fitsutil update >& fitsutil.f68881 & The spool file(s) should be reviewed upon completion to make sure there were no errors. fitsutil-2018.07.06/bin000077700000000000000000000000001332007674300165632bin.genericustar00rootroot00000000000000fitsutil-2018.07.06/doc/000077500000000000000000000000001332007674300145345ustar00rootroot00000000000000fitsutil-2018.07.06/doc/mef.txt000066400000000000000000000152441332007674300160520ustar00rootroot00000000000000MEF INTERFACE The Multiple Extensions FITS (MEF) interface consist of a number of routines to mainly read a FITS Primary Data Unit or an Extension Unit and manipulate the data at a file level. Is up to the application to take care of any details regarding data structuring and manipulation. For example, the MEF interface will read a BINTABLE extension and give to the calling program a set of parameters like dimensionality, datatype, header buffer pointer and data portion offset from the beginning of the file. So far the routines available to an SPP program are: mef = mef_open (fitsfile, acmode, oldp) mef_rdhdr (mef, group, extname, extver) mef_rdhdr_exnv (mef,extname, extver) mef_wrhdr (mefi, mefo, in_phdu) [irdb]val = mefget[irdb] (mef, keyword) mefgstr (mef, keyword, outstr, maxch) mef_app_file (mefi, mefo) mef_copy_extn (mefi, mefo, group) mef_dummyhdr (fd, hdrfname) INITIALIZE mef = mef_open (fitsfile, acmode, oldp) Initializes the MEF interface and it should be the first routine to be called when making operations on FITS files using these set of routines. Returns a pointer to the mef structure. fitsfile. Pathname to the FITS file to be open. The general syntax is: dir$root.extn[group] dir: Directory name where the file resides root: Rootname extn: (optional) Extension name. Can be any extension string group: Extension number to be openned. The '[group]' string is optional and is not part of the disk filename. It is used to specified which extension number to open. The extension number is zero based. Zero for the primary extension, 1 for the first extension and so on. acmode. The access mode of the file. The posible values are: READ_ONLY READ_WRITE APPEND NEW_FILE oldp. Not used. Reserve for future use. HEADER ROUTINES mef_rdhdr (mef, group, extname, extver) Read the FITS header on a MEF file that matches the EXTNAME or EXTVER keyword values or if not specified, reads the extension number 'group'. If no extension is found an error is posted. After reading the header the file pointer is position at the end of the last data FITS block (2880 bytes). mef. The Mef pointer returned by mef_open. When the routine returns, all of the elements of the MEF structure will have values belonging to the header just read. group. The extension number to be read. Zero for the Primary data unit, 1 for the first extension and so on. If you want to find out an extension by the value of extname and/or extver then 'group' should be -1. extname. The string that will match the EXTNAME value of any extension. The first match is the extension header returned. extver. The integer value that will match the EXTVER value of any extension. If 'extname' is not null then both values need to match before the routine returns. If there are no value to match then 'extver' should be INDEFL. mef_rdhdr_gn (mef,group) Read extension number 'group'. If the extension number does not exists, an error is posted. mef. The Mef pointer returned by mef_open. When the routine returns, all of the elements of the MEF structure will have values belonging to the header just read. group. The extension number to be read. Zero for the Primary data unit, 1 for the first extension and so on. mef_rdhdr_exnv (mef,extname, extver) Read group based on the Extname and Extver values. If the group is not encountered, an error is posted. mef. The Mef pointer returned by mef_open. When the routine returns, all of the elements of the MEF structure will have values belonging to the header just read. extname. The string that will match the EXTNAME value of any extension. The first match is the extension header returned. extver. The integer value that will match the EXTVER value of any extension. If 'extname' is not null then both values need to match before the routine returns. If there are no value to match then 'extver' should be INDEFL. mef_wrhdr (mefi, mefo, in_phdu) Append the header from an input PHU or EHU to output file. 'mefi'. The input file mef pointer returned by mef_open. The header should have been read by now. 'mefo'. The output file mef pointer returned by mef_open. 'in_phdu'. Boolean value (true, false) stating whether the input header is the primary header or not. [irdb]val = mefget[irdb] (mef, keyword) [irdb]: integer, real, double or boolean Get a FITS header keyword value of the specified datatype; for example 'imgeti (mef, "NCOMB")' will return an integer value from the keyword 'NCOMB'. 'mef'. The input file mef pointer returned by mef_open. The header should have been read by now. 'keyword' The input string (case insensitive) keyword from which to return its value. mefgstr (mef, keyword, 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 Get the string value of a FITS encoded card. Strip leading and trailing whitespace and any quotes. 'mef'. The input file mef pointer returned by mef_open. The header should have been read by now. 'keyword' The input string (case insensitive) keyword from which to return its value. 'outstr' The output string with the value of input keyword. 'maxch' Lenght in chars of 'outstr'. FILE OPERATIONS mef_app_file (mefi, mefo) Appends a FITS file to an output file. If the file does not exist, a dummy Primary Header unit is first created. 'mefi'. The input file mef pointer returned by mef_open. The header should have been read by now. 'mefo'. The output file mef pointer returned by mef_open. mef_copy_extn (mefi, mefo, group) Copy a FITS extension given by its number 'group' into an output file. If the file does not exists, this extension becames a Primary Header Data unit of the output FITS file. If the output file already exists, the input extension gets appended. 'mefi'. The input file mef pointer returned by mef_open. The header should have been read by now. 'mefo'. The output file mef pointer returned by mef_open. 'group'. The input extension number to be append to the output file. mef_dummyhdr (fd, hdrfname) Write a dummy Primary header Unit with no data to a new file. Optionaly a header file with user keywords can be used. 'fd' The output file descriptor. 'hdrfname' The header filename. This is text file with a FITS header syntax that will be appended to the file. Each FITS card does not have to be of 80 characters long. The routine takes care of the correct padding. fitsutil-2018.07.06/doc/mef_design.txt000066400000000000000000000071571332007674300174070ustar00rootroot00000000000000Multiple Extension FITS files. August 1997 The MEF interface is a set of routines to manipulate single FITS files or Multiple Extensions FITS files. This interface complies with the FITS standard set by the NOST document. The MEF interface is an IRAF interface intended to be used within an SPP or Fortran program with the proper IRAF initialization routines. The user callable routines are: mef_open (filename, acmode, ofd) Integer procedure returning a pointer to the MEF structure. 'filename'. Pathname to the target FITS filename. Pathname consist of ldir$rootname.extn[group] ldir: Logical directory root: Rootname of the filename extn: (Optional) FITS filename extension. group: (Optional) The FITS extension number. Zero correspond to the the Primary Header Unit, 1 to the first extension on so on. If you specify group, the '[]' are required. 'acmode'. Access mode of the target file. It could READ_ONLY, READ_WRITE, NEW_FILE or APPEND. 'ofd'. Not used at the moment. Reserve for future use. mef = mef_open (filename, acmode, ofd|hsize) The MEF structure pointed by 'mef' consists of the following elements: MEF_FD # File descriptor MEF_HOFF # Header offset in chars MEF_ACMODE # Access mode MEF_ENUMBER # Absolute extension number MEF_EXTVER # EXTVER keyword value MEF_CGROUP # Current group read MEF_HSIZE # Header size MEF_HDRP # Header area pointer MEF_POFF # Offset to pixel area in chars MEF_NDIM # Unit dimensionality MEF_NAXIS # Lenght of each exis MEF_BITPIX # Value of BITPIX MEF_EXTTYPE # XTENSION keyword value MEF_FNAME # Filename MEF_OBJECT # OBJECT keyword value MEF_EXTNAME # EXTNAME keyword value mef_close mef_close (mef) Free the memory allocated by mef_open and close the target FITS file. mef_query mef_query (filename, ext_type, datatype, object) Mefopen already does this, the difference would be for example that mef_query would just returns its argument values. No need to open and close. Another approach is to open the file, and mef_query would just return and value per request, for example mef_stati val = mef_stati (mef, "EXT_TYPE") to get the value of a mef descriptor element. mef_delete Make a temporary copy of file and copy the rest of the extensions. Delete the old one. mef_delete (mef) mef_rename Considering that an extension is a portion of a file, renaming would be limited to change the names of the EXTNAME and/or EXTVER values. No extractions to a different filename would be allowed. mef_rename (in_mef, oldname, new_name, unique(YES|NO)) Does the new_name need to be unique? mef_extract Make a copy of an extension into a new or existent file. mef_extract (file.fits[4], output_file, new|append) mef_insert Insert an extension after an existent one. Again a temporary file would be necessary to preserve the integrity of the target file. mef_insert (in_mef, out_mef, out_extn) mef_overwrite This would equivalent to delete an insert but only one temporary file would be necessary. mef_overwrite (in_mef, out_mef, out_extn) gethdkw Get keyword value, e.g. real = gethdkwr (mef, keyword) val = gethdkw[bsird] (mef, keyword) call gethdkwstring (mef, keyword, buf, max_size) puthdkw Put keyword value (new or update value), e.g. call puthdkw[bsird] (mef, keyword, value, comment) call puthdkwstring (mef, keyword, value, max_size, comment) fitsutil-2018.07.06/fitsutil.cl000066400000000000000000000021741332007674300161560ustar00rootroot00000000000000#{ FITSUTIL.CL -- The FITSUTIL package print ("This is the initial release of the IRAF FITSUTIL package") print ("to include support for FITS tile compression via 'fpack'.") print ("Please send comments and questions to seaman@noao.edu.") print ("") cl < "fitsutil$/lib/zzsetenv.def" package fitsutil, bin = fitsutilbin$ task fxheader, fxdummyh, fxinsert, fxdelete, fxextract, fxsplit, fxconvert, fxplf, fxcopy = "fitsutil$src/x_fitsutil.e" task ricepack = "fitsutil$src/ricepack.cl" task fpack = "fitsutil$src/fpack.cl" task funpack = "fitsutil$src/funpack.cl" task sum32 = "fitsutil$src/sum32.cl" task $t_fpack = ("$" // osfn("fitsutilbin$") // "fpack") task $t_funpack = ("$" // osfn("fitsutilbin$") // "funpack") task $t_sum32 = ("$" // osfn("fitsutilbin$") // "sum32") hidetask t_fpack hidetask t_funpack hidetask t_sum32 task fgwrite = "fitsutil$src/fgwrite.cl" task fgread = "fitsutil$src/fgread.cl" task $t_fgwrite = ("$" // osfn("fitsutilbin$") // "fgwrite.e $*") task $t_fgread = ("$" // osfn("fitsutilbin$") // "fgread.e $*") hidetask t_fgwrite hidetask t_fgread clbye() ; fitsutil-2018.07.06/fitsutil.hd000066400000000000000000000016111332007674300161460ustar00rootroot00000000000000# Help directory for the FITSUTIL package. $doc = "fitsutil$src/doc/" $srcdir = "fitsutil$src/" fitsutil hlp="fitsutil$fitsutil.men" fxcopy hlp=doc$fxcopy.hlp, src=srcdir$fxcopy.x fxconvert hlp=doc$fxconvert.hlp, src=srcdir$fxconvert.x fxdelete hlp=doc$fxdelete.hlp, src=srcdir$fxdelete.x fxinsert hlp=doc$fxinsert.hlp, src=srcdir$fxinsert.x fxheader hlp=doc$fxheader.hlp, src=srcdir$fxheader.x fxextract hlp=doc$fxextract.hlp, src=srcdir$fxextract.x fxsplit hlp=doc$fxsplit.hlp, src=srcdir$fxsplit.x fxdummyh hlp=doc$fxdummyh.hlp, src=srcdir$fxdummyh.x fxplf hlp=doc$fxplf.hlp, src=srcdir$fxplf.x fpack hlp=doc$fpack.hlp, src=srcdir$fpack.cl funpack hlp=doc$funpack.hlp, src=srcdir$funpack.cl ricepack hlp=doc$ricepack.hlp, src=srcdir$ricepack.cl sum32 hlp=doc$sum32.hlp, src=srcdir$sum32.cl fgwrite hlp=doc$fgwrite.hlp, src=srcdir$fgwrite.c fgread hlp=doc$fgread.hlp, src=srcdir$fgread.c fitsutil-2018.07.06/fitsutil.men000066400000000000000000000023511332007674300163340ustar00rootroot00000000000000 fgread - Read a MEF file with FOREIGN extensions fgwrite - Create a MEF file with FOREIGN extensions fpack - USE RICEPACK INSTEAD funpack - Uncompress a FITS file fxconvert- Convert between IRAF image types. fxcopy - Copy FITS files or FITS extension to an output FITS file fxdelete - Delete FITS extensions in place fxdummyh - Create a dataless single FITS file fxextract- Extract a FITS extension fxheader - List one line of header description per FITS unit fxinsert - Insert FITS files or extensions into another MEF file fxplf - Converts a pixel list file into a BINTABLE extension fxsplit - Split a multiple extension FITS file into single FITS files ricepack - Rice compress a FITS file sum32 - Compute the 32-bit FITS 1's complement checksum The CFITSIO fpack command (http://heasarc.gsfc.nasa.gov/fitsio/fpack) is a general purpose tool that allows varying many compression options when creating tile compressed FITS files. It is anticipated, however, that the great majority of astronomical usage will involve the Rice algorithm. This release of IRAF FITSUTIL is focused on providing streamlined access to this functionality through the RICEPACK task. Please contact seaman@noao.edu with comments and questions. fitsutil-2018.07.06/fitsutil.par000066400000000000000000000000741332007674300163370ustar00rootroot00000000000000# fitsutil package parameter file. version,s,h,"2018.07.06" fitsutil-2018.07.06/fitsutil.readme000066400000000000000000000001611332007674300170070ustar00rootroot00000000000000Fitsutil. This package is under development. Any comments can be sent to fits@noao.edu and they are appreciated. fitsutil-2018.07.06/format.mip000066400000000000000000000001531332007674300157650ustar00rootroot00000000000000EXT# -5.5 EXTTYPE -19.19 EXTNAME -13.13 EXTVER -5.5 DIMENS -10.10 BITPIX -5.5 INHERIT -3.3 OBJECT -12.12 fitsutil-2018.07.06/format_off.mip000066400000000000000000000001571332007674300166230ustar00rootroot00000000000000EXT# -5.5 EXTTYPE -9.9 EXTNAME -11.11 EXTVER -5.5 DIMENS -10.10 BITPIX -5.5 INHERIT -3.3 HOFF -9.9 POFF -9.9 fitsutil-2018.07.06/lib/000077500000000000000000000000001332007674300145355ustar00rootroot00000000000000fitsutil-2018.07.06/lib/helpdb.mip000066400000000000000000000074601332007674300165110ustar00rootroot00000000000000D:1¥ ˆšBBB%rootdefdir=fitsutil$lib/_fitsutilfitsutil$lib/rootfitsutil.hdB˜B#BXƒn,rootfitsutildefdir=fitsutil$lib/fitsutilfitsutil$fitsutil.menfitsutil$fitsutil.menfitsutil$fitsutil.hlpfitsutil$fitsutil.hdfitsutil$fitsutil.clœÅ œ*Ÿ¦µv~Ž8A×Ýëû}‡™W^m¬µÆˆ‘¢0:L Øáò´ºÈ_gw%.?RXffitsutildefdir=fitsutil$doc=./src/doc/srcdir=./src/fitsutilfitsutil$fitsutil.menfxcopydoc$fxcopy.hlpsrcdir$fxcopy.xfxconvertdoc$fxconvert.hlpsrcdir$fxconvert.xfxdeletedoc$fxdelete.hlpsrcdir$fxdelete.xfxinsertdoc$fxinsert.hlpsrcdir$fxinsert.xfxheaderdoc$fxheader.hlpsrcdir$fxheader.xfxextractdoc$fxextract.hlpsrcdir$fxextract.xfxsplitdoc$fxsplit.hlpsrcdir$fxsplit.xfxdummyhdoc$fxdummyh.hlpsrcdir$fxdummyh.xfxplfdoc$fxplf.hlpsrcdir$fxplf.xfpackdoc$fpack.hlpsrcdir$fpack.clfunpackdoc$funpack.hlpsrcdir$funpack.clricepackdoc$ricepack.hlpsrcdir$ricepack.clsum32doc$sum32.hlpsrcdir$sum32.clfgwritedoc$fgwrite.hlpsrcdir$fgwrite.cfgreaddoc$fgread.hlpsrcdir$fgread.cN¸N&CLbx¢_rootfitsutil$lib/root.hd_fitsutilfitsutil$lib/rootfitsutil.hdfitsutilfitsutil$fitsutil.menfitsutil$fitsutil.hlpfitsutil$fitsutil.clfitsutil$fitsutil.hdfitsutil$fitsutil.men_indexð:1¥fitsutil$fitsutil.hdñ:³Àfitsutil$lib/root.hd!1fitsutil$lib/rootfitsutil.hdc!‚fitsutil-2018.07.06/lib/libmef.a000077700000000000000000000000001332007674300205132../bin/libmef.austar00rootroot00000000000000fitsutil-2018.07.06/lib/mef.h000066400000000000000000000035431332007674300154620ustar00rootroot00000000000000define LEN_CARD 80 define SZ_EXTTYPE 20 define LEN_CARDNL 81 define SZ_KEYWORD 8 define FITS_STARTVALUE 10 define FITS_ENDVALUE 30 define FITS_BLKSZ_CHAR 1440 # Number of chars per FITS block define FITS_BLKSZ_NL 2916 # 36*81 define FITS_BLOCK_BYTES 2880 define MEF_SZVALSTR 68 define FITS_ORIGIN "NOAO-IRAF FITS MEF utility Sep99" define LEN_MEF 271 define MEF_FD Memi[$1] # File descriptor define MEF_HOFF Memi[$1+2] # Header offset in chars define MEF_ACMODE Memi[$1+3] # Access mode define MEF_ENUMBER Memi[$1+4] # Absolute extension number define MEF_EXTVER Memi[$1+5] # Extension version define MEF_CGROUP Memi[$1+6] # Current group read define MEF_HFLAG Memi[$1+7] # Header update flag define MEF_HSIZE Memi[$1+8] # Header size define MEF_HDRP Memi[$1+9] # Header area pointer define MEF_POFF Memi[$1+10] # Offset to pixel area (chars) define MEF_NDIM Memi[$1+11] # Unit dimensionality define MEF_NAXIS Memi[$1+$2+12-1] # Upto 7 axis define MEF_BITPIX Memi[$1+18] # Unit datatype define MEF_DATATYPE Memi[$1+19] # Unit datatype define MEF_SKDATA Memi[$1+20] # Has data been skipped? define MEF_PCOUNT Memi[$1+21] # Has data been skipped? define MEF_KEEPXT Memi[$1+22] # Has data been skipped? define MEF_EXTTYPE Memc[P2C($1+23)] # Extension type define MEF_FNAME Memc[P2C($1+63)] # Filename define MEF_OBJECT Memc[P2C($1+191)] # Object define MEF_EXTNAME Memc[P2C($1+231)] # Extension name define NEW_UNIT NEW_FILE define SIMPLE 1 define NAXIS 2 define NAXISN 3 define EXTNAME 4 define EXTVER 5 define END 6 define BITPIX 7 define EXTEND 8 define OBJECT 9 define PCOUNT 10 define GCOUNT 11 define INHERIT 12 define FILENAME 13 define XTENSION 14 fitsutil-2018.07.06/lib/meflib/000077500000000000000000000000001332007674300157735ustar00rootroot00000000000000fitsutil-2018.07.06/lib/meflib/Notes000066400000000000000000000015321332007674300170070ustar00rootroot00000000000000 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 fitsutil-2018.07.06/lib/meflib/mefappfile.x000066400000000000000000000047601332007674300203030ustar00rootroot00000000000000include # 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 char card[80] begin if (olines > 36) nlines = 72 - olines else nlines = 36 - olines 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 fitsutil-2018.07.06/lib/meflib/mefclose.x000066400000000000000000000004411332007674300177600ustar00rootroot00000000000000include # 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 fitsutil-2018.07.06/lib/meflib/mefcpextn.x000066400000000000000000000020571332007674300201610ustar00rootroot00000000000000include 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 fitsutil-2018.07.06/lib/meflib/mefdummyh.x000066400000000000000000000043061332007674300201620ustar00rootroot00000000000000include # 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 fitsutil-2018.07.06/lib/meflib/mefencode.x000066400000000000000000000325571332007674300201250ustar00rootroot00000000000000include 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 fitsutil-2018.07.06/lib/meflib/mefget.x000066400000000000000000000070601332007674300174360ustar00rootroot00000000000000# 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, imgstr begin call smark (sp) call salloc (sval, SZ_LINE, TY_CHAR) ip = 1 call mefgstr (mef, key, Memc[sval], SZ_LINE) 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 fitsutil-2018.07.06/lib/meflib/mefgnbc.x000066400000000000000000000020401332007674300175610ustar00rootroot00000000000000include # 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 fitsutil-2018.07.06/lib/meflib/mefgval.x000066400000000000000000000071521332007674300176120ustar00rootroot00000000000000include 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 fitsutil-2018.07.06/lib/meflib/mefkfind.x000066400000000000000000000031771332007674300177570ustar00rootroot00000000000000include 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 fitsutil-2018.07.06/lib/meflib/mefksection.x000066400000000000000000000101001332007674300204630ustar00rootroot00000000000000include 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 fitsutil-2018.07.06/lib/meflib/mefldhdr.x000066400000000000000000000055171332007674300177610ustar00rootroot00000000000000include 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 fitsutil-2018.07.06/lib/meflib/mefopen.x000066400000000000000000000042111332007674300176130ustar00rootroot00000000000000include # 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 fitsutil-2018.07.06/lib/meflib/mefrdhdr.x000066400000000000000000000164011332007674300177610ustar00rootroot00000000000000include 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() 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) return (cur_extn) 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 fitsutil-2018.07.06/lib/meflib/mefsetpl.x000066400000000000000000000113031332007674300200010ustar00rootroot00000000000000include 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 fitsutil-2018.07.06/lib/meflib/mefwrhdr.x000066400000000000000000000113561332007674300200100ustar00rootroot00000000000000include 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 fitsutil-2018.07.06/lib/meflib/mefwrpl.x000066400000000000000000000117021332007674300176410ustar00rootroot00000000000000include 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 fitsutil-2018.07.06/lib/meflib/mkpkg000066400000000000000000000011751332007674300170330ustar00rootroot00000000000000$checkout libmef.a ../ $update libmef.a $checkin libmef.a ../ $exit libmef.a: #$set XFLAGS='-cfgq -p fitsutil' mefopen.x mefksection.x mefrdhdr.x mefwrhdr.x mefclose.x mefgval.x mefgnbc.x mefget.x mefkfind.x mefappfile.x mefdummyh.x mefcpextn.x mefencode.x mefsetpl.x mefwrpl.x mefldhdr.x ; fitsutil-2018.07.06/lib/mkpkg000066400000000000000000000005061332007674300155720ustar00rootroot00000000000000# Make the MEF library # # Special keywords recognized by IRAF mkpkg files: # # mkpkg relink update object library and link # mkpkg install move executable to lib$ # mkpkg update update object library, link, and move to lib$ relink: install: update: #$update libmef.a $call install@cfitsio $exit libmef.a: @meflib ; fitsutil-2018.07.06/lib/mkpkg.inc000066400000000000000000000002661332007674300163450ustar00rootroot00000000000000# Global MKPKG definitions for the FITSUTIL package. $set XFLAGS = "$(XFLAGS) -p fitsutil" $set XVFLAGS = "$(XVFLAGS) -p fitsutil" $set LFLAGS = "$(LFLAGS) -p fitsutil" fitsutil-2018.07.06/lib/root.hd000066400000000000000000000004221332007674300160330ustar00rootroot00000000000000# Root help directory for the fitsutil packages. This dummy package is # necessary in order to have `fitsutil' appear as a module in some package, # so that the user can type "help fitsutil" (with `fitsutil' given as a task). _fitsutil pkg = fitsutil$lib/rootfitsutil.hd fitsutil-2018.07.06/lib/rootfitsutil.hd000066400000000000000000000004521332007674300176220ustar00rootroot00000000000000# Root task entry for the IMCNV package help tree. Defines `fitsutil' # as both a task and a package in the fitsutil help database. fitsutil men = fitsutil$fitsutil.men, hlp = fitsutil$fitsutil.men, sys = fitsutil$fitsutil.hlp, pkg = fitsutil$fitsutil.hd, src = fitsutil$fitsutil.cl fitsutil-2018.07.06/lib/zzsetenv.def000066400000000000000000000003121332007674300171010ustar00rootroot00000000000000# Global environment definitions for the FITSUTIL packages. reset pkglibs = "fitsutil$bin(arch)/,fitsutil$lib/" reset fitsutilbin = "fitsutil$bin(arch)/" reset fitsutillibs = "fitsutil$lib/" keep fitsutil-2018.07.06/mkpkg000066400000000000000000000070651332007674300150330ustar00rootroot00000000000000# Make the FITSUTIL external package # # Author: N Zarate # $ifeq (hostid, unix) !(clear;date) $endif $call update $ifeq (hostid, unix) !(date) $endif $exit linkonly: $call src $ifeq (HOSTID, vms) $purge [...] $endif $purge mefbin$ ; update: $call lib $call src $ifeq (HOSTID, vms) $purge [...] $endif $purge mefbin$ ; lib: $echo "===================== LIB =========================" $echo "" $call update@lib ; src: $echo "===================== PKG =========================" $echo "" $call update@src ; # STRIP -- Strip the TABLES directories of all sources and other files not # required to run the system, or for user programming. strip: !rmfiles -f lib/strip.mef ; # SUMMARY -- [UNIX] mkpkg summary: output a summary of the spooled mkpkg # output, omitting most of the mundane chatter. Used to scan large spool # files for errors. summary: $ifeq (HOSTID, unix) ! grep -v ':$$' spool | grep -v '^xc' | grep -v '^ar'\ | grep -v '^check file' $else $echo "mkpkg summary only available on a UNIX system" $endif ; # IRAF multiple architecture support. # ---------------------------------------- arch: # show current float option showfloat: $verbose off !$(hlib)/mkfloat.csh ; generic: # generic installation (no bin) $ifnfile (bin.generic) !mkdir bin.generic $endif $verbose off $set DIRS = "lib src" !$(hlib)/mkfloat.csh generic -d $(DIRS) ; freebsd: # install FreeBSD binaries $ifnfile (bin.freebsd) !mkdir bin.freebsd $endif $verbose off $set DIRS = "lib src" !$(hlib)/mkfloat.csh freebsd -d $(DIRS) ; linux: # install Slackwkare Linux binaries $ifnfile (bin.linux) !mkdir bin.linux $endif $verbose off $set DIRS = "lib src" !$(hlib)/mkfloat.csh linux -d $(DIRS) ; linux64: # install x86_64 binaries $ifnfile (bin.linux64) !mkdir bin.linux64 $endif $verbose off $set DIRS = "lib src" !$(hlib)/mkfloat.csh linux64 -d $(DIRS) ; macosx: # install Mac OS X (PPC) binaries $ifnfile (bin.macosx) !mkdir bin.macosx $endif $verbose off $set DIRS = "lib src" !$(hlib)/mkfloat.csh macosx -d $(DIRS) ; macintel: # install Mac OS X (Intel) binaries $ifnfile (bin.macintel) !mkdir bin.macintel $endif $verbose off $set DIRS = "lib src" !$(hlib)/mkfloat.csh macintel -d $(DIRS) ; cygwin: # install Cygwin binaries $ifnfile (bin.cygwin) !mkdir bin.cygwin $endif $verbose off $set DIRS = "lib src" !$(hlib)/mkfloat.csh cygwin -d $(DIRS) ; redhat: # install Redhat Linux binaries $ifnfile (bin.redhat) !mkdir bin.redhat $endif $verbose off $set DIRS = "lib src" !$(hlib)/mkfloat.csh redhat -d $(DIRS) ; sparc: # install sparc binaries $ifnfile (bin.sparc) !mkdir bin.sparc $endif $verbose off $set DIRS = "lib src" !$(hlib)/mkfloat.csh sparc -d $(DIRS) ; ssun: # install Sun/Solaris binaries $ifnfile (bin.ssun) !mkdir bin.ssun $endif $verbose off $set DIRS = "lib src" !$(hlib)/mkfloat.csh ssun -d $(DIRS) ; sunos: # install SunOS (Solaris x86) binaries $ifnfile (bin.sunos) !mkdir bin.sunos $endif $verbose off $set DIRS = "lib src" !$(hlib)/mkfloat.csh sunos -d $(DIRS) ; fitsutil-2018.07.06/src/000077500000000000000000000000001332007674300145565ustar00rootroot00000000000000fitsutil-2018.07.06/src/Notes000066400000000000000000000054511332007674300155760ustar00rootroot00000000000000 fxcopy.x Add local copy of ranges.x. The routines calls have now an 'l' preappended to get_netx_number() and decode_ranges() The to use these calls was to take advantage of the zero index support on this calls. Take the 'gz' support out. mar.4.98 nz fxdelete.x fxinsert.x Use the local copy of ranges that is in fxcopy.x mar.4.98 nz Version 1.0 released 4/98 ================================================================== fxrdhdr.x fxfwrhdr.x Change the algorithm to skip extensions. Add new struct element MEF_KEEPXT. When 'yes', it will not touch the header extension and pass it to the output as is. Good for extracting extension as they are. aug.30.99 nz fgread.c,fgwrite.c Added 2 new foreign task. There is a wrapper cl script for each to allow parameter editing before executing the C program. Version 1.2 release Sep99 ==================================================================== fxheader.x This task can now list FITS files that do not have filename extensions; e.g. the file 'foof' exist and 'fxf foof' works OK now. You can omit the '.fits' extension now and the task would work ok for complex files names like: 'foo_n12.fhf.fits'. If the EXTNAME keyword is not located in within the first 36 cards then its value would not get displayed. This bug has been fixed now. Gemini files with MDF extension is one of this examples. nz 2 Oct 2003 =================================================================== mefendecode.x Put the lranges routines that where on pkg/fxfcopy.x to be available to user application via meflib.a mefldhdr.x New routine. Load a FITS header from a file descriptor into a spool file. mefget.x/mefgetb() add "errchk mef_findkw" to jump to the calling routine when an error has occurred. If the keyword does not exist should give and error rather than F. ============================================================== catprhdr.x Revised the code to make much simpler. Change mef_rdhdr.x to be a function now. Jan.06.04 nhedit.x Added this temporary task until we put it somewhere else. nz Dec 21, 04 ================================================================== lib/cfitsio ricepack.cl funpack.cl fpack.cl Added tasks to perform FITS tile compression layered on CFITSIO/fpack. Ricepack performs a streamlined tile compression using the Rice algorithm. Funpack will unpack any general tile compressed file. Input/output can be uncompressed SIF or MEF FITS, IRAF .imh files, or gzipped FITS. General fpack support will follow after ongoing CFITSIO development concludes, especially floating point support. January 2010, R. Seaman sum32.cl sum32.c checksum.c Added task to calculate FITS checksum. This is also built into FITS tile compression. January 2010, R. Seaman doc Help pages for these. January 2010, R. Seaman fitsutil-2018.07.06/src/catprhdr.x000066400000000000000000000120421332007674300165550ustar00rootroot00000000000000include include include "dfits.h" # CAT_PRINT_HEADER -- Procedure to read FITS tape or disk file # and print part of its content. int procedure cat_print_header (fitsfile, number, count_lines, short_header, ksection) char fitsfile[SZ_FNAME] # Fits file name int number # input file number bool count_lines # I Do we want line number on long output? int short_header # I YES,NO char ksection[ARB] pointer mef, mef_open() int enumber, ecount, extver, stat int mef_rdhdr_gn(), mef_rdhdr_exnv() char extname[LEN_CARD] errchk mef_open, mef_rdhdr_gn, mef_rdhdr_exnv begin mef = mef_open( fitsfile, READ_ONLY, 0) enumber = MEF_ENUMBER(mef) call mef_ksection (ksection, extname, extver) ecount = 0 if (enumber == -1 && ksection[1] == EOS) { # Do all the extensions in the file while (mef_rdhdr_gn(mef, ecount) != EOF) { call cat_print_unit (mef, ecount, short_header, count_lines) ecount = ecount + 1 } call mef_close(mef) if (ecount > 1) return(-3) else return(EOF) } else { # Do only one extension if (ksection[1] != EOS) { stat = mef_rdhdr_exnv (mef, extname, extver) enumber = MEF_CGROUP(mef) - 1 } else stat = mef_rdhdr_gn (mef, enumber) if (stat == EOF) { if (enumber > MEF_CGROUP(mef)) { call sprintf(extname, LEN_CARD, "Extension not found: %s[%d]") call pargstr(MEF_FNAME(mef)) call pargi(enumber) call mef_close(mef) call error(13, extname) } if (MEF_CGROUP(mef) < 0) { call sprintf(extname, LEN_CARD, "Extension not found: %s%s") call pargstr(MEF_FNAME(mef)) call pargstr(ksection) call mef_close(mef) call error(13, extname) } call mef_close(mef) return (EOF) } call cat_print_unit (mef, enumber, short_header, count_lines) } call mef_close(mef) return (0) end # CAT_PRINT_MAIN - Output to stdout and/or the the log_file one # line of information per input fits file according to the field # specifications in the file format_file. procedure cat_print_unit (mef, number, short_header, count_lines) pointer mef # Mef descriptor int number # input extension sequence int short_header # YES. Print one line per FITS unit bool count_lines # YES, NO. Print line number of long output char str[LEN_CARD] # card data string int nk, i, nch char sdim[SZ_KEYWORD] char line[SZ_LINE] int nl, nbc, fd int strmatch(), itoc(), strcmp(), stropen(), getline(), mef_gnbc() include "dfits.com" begin if (short_header != YES) { # Print the entire FITS header. call printf("\nFile: %s[%d] *************************\n") call pargstr(MEF_FNAME(mef)) call pargi(number) fd = stropen (Memc[MEF_HDRP(mef)], ARB, READ_ONLY) if (!count_lines) while(getline(fd, line) != EOF) { call printf("%s") call pargstr(line) } else { nl = 1 while(getline(fd, line) != EOF) { call printf("%2.2d: %75.75s\n") call pargi(nl) call pargstr(line) nl = nl + 1 } } call close(fd) }else { # Search the keyword in the card table line[1] = EOS do nk = 1, nkeywords { if (strcmp (Memc[key_table[nk]], "EXT#") == 0) { nch= itoc (number, str, LEN_CARD) } else if (strmatch (Memc[key_table[nk]], "EXTNAME") > 0) { if (MEF_EXTNAME(mef) == EOS) call mefgstr (mef, "EXTNAME", MEF_EXTNAME(mef), MEF_SZVALSTR) call strcpy (MEF_EXTNAME(mef), str, LEN_CARD) } else if (strmatch (Memc[key_table[nk]], "DIMENS") > 0) { str[1] = EOS do i = 1, MEF_NDIM(mef) { nch= itoc (MEF_NAXIS(mef,i), sdim, SZ_KEYWORD) call strcat (sdim, str, LEN_CARD) if (i != MEF_NDIM(mef)) call strcat ("x", str, LEN_CARD) } } else if (strmatch (Memc[key_table[nk]], "EXTVER") > 0) { if (MEF_EXTVER(mef) == INDEFL) str[1] = EOS else nch= itoc (MEF_EXTVER(mef), str, SZ_KEYWORD) } else if (strmatch (Memc[key_table[nk]], "BITPIX") > 0) { nch= itoc (MEF_BITPIX(mef), str, SZ_KEYWORD) } else if (strmatch (Memc[key_table[nk]], "EXTTYPE") > 0) { if (number > 0) { # Right justify one space str[1] = ' ' i = 2 call strcpy (MEF_EXTTYPE(mef), str[i], LEN_CARD) } else { i = 1 call strcpy (MEF_FNAME(mef), str[i], LEN_CARD) } } else if (strcmp (Memc[key_table[nk]], "HOFF") == 0) { i = (MEF_HOFF(mef)-1)*2 nch= itoc (i, str, LEN_CARD) } else if (strcmp (Memc[key_table[nk]], "NBC") == 0) { nbc = mef_gnbc (mef) nch= itoc (nbc, str, LEN_CARD) } else if (strcmp (Memc[key_table[nk]], "POFF") == 0) { i = (MEF_POFF(mef)-1)*2 if (MEF_NDIM(mef) == 0) i = INDEFL nch= itoc (i, str, LEN_CARD) } else { iferr (call mef_findkw (MEF_HDRP(mef), Memc[key_table[nk]], str)) str[1] = EOS } call print_string (line, str, Memc[fmt_table[nk]], opt_table[nk]) } call printf("%80.80s\n") call pargstr(line) } end fitsutil-2018.07.06/src/checksum.c000066400000000000000000000156601332007674300165340ustar00rootroot00000000000000/* Explicitly exclude those ASCII characters that fall between the * upper and lower case alphanumerics (<=>?@[\]^_`) from the encoding. * Which is to say that only the digits 0-9, letters A-Z, and letters * a-r should appear in the ASCII coding for the unsigned integers. */ #define NX 13 unsigned exclude[NX] = { 0x3a, 0x3b, 0x3c, 0x3d, 0x3e, 0x3f, 0x40, 0x5b, 0x5c, 0x5d, 0x5e, 0x5f, 0x60 }; int offset = 0x30; /* ASCII 0 (zero) character */ /* CHECKSUM -- Increment the checksum of a character array. The * calling routine must zero the checksum initially. Shorts are * assumed to be 16 bits, ints 32 bits. */ /* Internet checksum algorithm, 16/32 bit unsigned integer version: */ checksum (buf, length, sum16, sum32) unsigned char *buf; int length; unsigned short *sum16; unsigned int *sum32; { int len, remain, i; unsigned int hi, lo, hicarry, locarry, tmp16; len = 4*(length / 4); /* make sure len is a multiple of 4 */ remain = length % 4; /* add remaining bytes below */ /* Extract the hi and lo words - the 1's complement checksum * is associative and commutative, so it can be accumulated in * any order subject to integer and short integer alignment. * By separating the odd and even short words explicitly, both * the 32 bit and 16 bit checksums are calculated (although the * latter follows directly from the former in any case) and more * importantly, the carry bits can be accumulated efficiently * (subject to short integer overflow - the buffer length should * be restricted to less than 2**17 = 131072). */ hi = (*sum32 >> 16); lo = *sum32 & 0xFFFF; for (i=0; i < len; i+=4) { hi += (buf[i] << 8) + buf[i+1]; lo += (buf[i+2] << 8) + buf[i+3]; } /* any remaining bytes are zero filled on the right */ if (remain) { if (remain >= 1) hi += buf[2*len] * 0x100; if (remain >= 2) hi += buf[2*len+1]; if (remain == 3) lo += buf[2*len+2] * 0x100; } /* fold the carried bits back into the hi and lo words */ hicarry = hi >> 16; locarry = lo >> 16; while (hicarry || locarry) { hi = (hi & 0xFFFF) + locarry; lo = (lo & 0xFFFF) + hicarry; hicarry = hi >> 16; locarry = lo >> 16; } /* simply add the odd and even checksums (with carry) to get the * 16 bit checksum, mask the two to reconstruct the 32 bit sum */ tmp16 = hi + lo; while (tmp16 >> 16) tmp16 = (tmp16 & 0xFFFF) + (tmp16 >> 16); *sum16 = tmp16; *sum32 = (hi << 16) + lo; } /* CHAR_ENCODE -- Encode an unsigned integer into a printable ASCII * string. The input bytes are each represented by four output bytes * whose sum is equal to the input integer, offset by 0x30 per byte. * The output is restricted to alphanumerics. * * This is intended to be used to embed the complement of a file checksum * within an (originally 0'ed) ASCII field in the file. The resulting * file checksum will then be the 1's complement -0 value (all 1's). * This is an additive identity value among other nifty properties. The * embedded ASCII field must be 16 or 32 bit aligned, or the characters * can be permuted to compensate. * * To invert the encoding, simply subtract the offset from each byte * and pass the resulting string to checksum. */ char_encode (value, ascii, nbytes, permute) unsigned int value; char *ascii; /* at least 17 characters long */ int nbytes; int permute; { int byte, quotient, remainder, ch[4], check, i, j, k; char asc[32]; for (i=0; i < nbytes; i++) { byte = (value << 8*(i+4-nbytes)) >> 24; /* Divide each byte into 4 that are constrained to be printable * ASCII characters. The four bytes will have the same initial * value (except for the remainder from the division), but will be * shifted higher and lower by pairs to avoid special characters. */ quotient = byte / 4 + offset; remainder = byte % 4; for (j=0; j < 4; j++) ch[j] = quotient; /* could divide this between the bytes, but the 3 character * slack happens to fit within the ascii alphanumeric range */ ch[0] += remainder; /* Any run of adjoining ASCII characters to exclude must be * shorter (including the remainder) than the runs of regular * characters on either side. */ check = 1; while (check) for (check=0, k=0; k < NX; k++) for (j=0; j < 4; j+=2) if (ch[j]==exclude[k] || ch[j+1]==exclude[k]) { ch[j]++; ch[j+1]--; check++; } /* ascii[j*nbytes+(i+permute)%nbytes] = ch[j]; */ for (j=0; j < 4; j++) asc[j*nbytes+i] = ch[j]; } for (i=0; i < 4*nbytes; i++) ascii[i] = asc[(i+4*nbytes-permute)%(4*nbytes)]; ascii[4*nbytes] = 0; } /* ADD_1S_COMP -- add two unsigned integer values using 1's complement * addition (wrap the overflow back into the low order bits). Could do * the same thing using checksum(), but this is a little more obvious. * To subtract, just complement (~) one of the arguments. */ unsigned int add_1s_comp (u1, u2) unsigned int u1, u2; { unsigned int hi, lo, hicarry, locarry; hi = (u1 >> 16) + (u2 >> 16); lo = ((u1 << 16) >> 16) + ((u2 << 16) >> 16); hicarry = hi >> 16; locarry = lo >> 16; while (hicarry || locarry) { hi = (hi & 0xFFFF) + locarry; lo = (lo & 0xFFFF) + hicarry; hicarry = hi >> 16; locarry = lo >> 16; } return ((hi << 16) + lo); } /********************************* * * * other checksum algorithms: * * * *********************************/ /* Internet (1's complement) checksum: */ unsigned int addcheck (sum, array, length) unsigned int *sum; char *array; int length; { register int i; unsigned short *iarray; int len; iarray = (unsigned short *) array; len = length / 2; for (i=0; i>16) *sum = (*sum & 0xFFFF) + (*sum>>16); return (*sum); } /* Internet checksum, 32 bit unsigned integer version: */ unsigned int addcheck32 (sum, array, length) unsigned int *sum; char *array; int length; { register int i; unsigned int *iarray; int len, carry=0, newcarry=0; iarray = (unsigned int *) array; len = length / 4; for (i=0; i ~ *sum) carry++; *sum += iarray[i]; } while (carry) { if (carry > ~ *sum) newcarry++; *sum += carry; carry = newcarry; newcarry = 0; } return (*sum); } /* ICE 16 bit microcode checksum: */ unsigned int addcheck1 (sum, array, length) unsigned int *sum; char *array; int length; { register int i; for (i = 0; i < length; i++) *sum += (*sum + array[i]); return (*sum); } /* BSD 16 bit sum algorithm: */ unsigned int addcheck2 (sum, array, length) unsigned int *sum; char *array; int length; { register int i; for (i = 0; i < length; i++) { if (*sum & 01) *sum = (*sum >> 1) + 0x8000; else *sum >>= 1; *sum += (unsigned char) array[i]; *sum &= 0xFFFF; } return (*sum); } fitsutil-2018.07.06/src/dfits.com000066400000000000000000000005601332007674300163700ustar00rootroot00000000000000# FITS reader common # Option flags bool form_header # Tables pointer log_fd # log file descriptor int nkeywords # number of keywords (and formats) stored pointer key_table[MAX_TABLE] # keywords pointer fmt_table[MAX_TABLE] # formats char opt_table[MAX_TABLE] # format options common /dfitscom/ log_fd, form_header, nkeywords, key_table, fmt_table, opt_table fitsutil-2018.07.06/src/dfits.h000066400000000000000000000011401332007674300160340ustar00rootroot00000000000000# DFITS Definitions # Define size of tables in memory define MAX_TABLE 30 # number of keywords and formats define MAX_CARDS 100 # number of cards # Define sizes of keywords and formats define SZ_KEYWORD 8 # length of keywords in characters define SZ_FORMAT 8 # length of formats in characters (%-dd.ddc) # Define test of formats define IS_STRING ($1 == 's') define IS_INTEGER ($1 == 'd' || $1 == 'o' || $1 == 'x') define IS_FLOAT (($1 >= 'e' && $1 <= 'h') || $1 == 'm') define IS_FORMAT (IS_STRING($1) || IS_INTEGER($1) || IS_FLOAT($1)) # Define possible formats define FORMAT_DICT "defghmosx" fitsutil-2018.07.06/src/dfits.x000066400000000000000000000207531332007674300160670ustar00rootroot00000000000000include include "dfits.h" # DFREAD_FORMATS - Read keywords and formats from a file. The keyword and # the format are extracted from the lines red from the file and are stored # in the stack. The pointers to the keywords and formats are stored in two # array in the common block (dfits.com). # The format strings are converted into FMTIO output format specification # as they are written into the table. procedure dfread_formats (name) char name[ARB] # file name of format file int ffd, ip, keylen, fmtlen char line[SZ_LINE], keyword[SZ_LINE], format[SZ_LINE] bool check_format() int open(), fscan(), strlen(), strext() include "dfits.com" begin # Open the format file ffd = open (name, READ_ONLY, TEXT_FILE) # Reset counter of keywords (and formats) stored nkeywords = 0 # Read the formats (lines) one by one and store it in a # table while (fscan (ffd) != EOF) { # Read line from the file call gargstr (line, SZ_LINE) # Extract keyword from line and test it ip =1 keylen = strext (line, ip, " ,", YES, keyword, SZ_LINE) if (keylen == 0) { call eprintf ("(%s) - Warning: No keyword found (skipped)\n") call pargstr (line) next } else if (keylen > SZ_KEYWORD) { call eprintf ("(%s) - Warning: Keyword too long (skipped) \n") call pargstr (line) next } else call strupr (keyword) # Extract format from line and test it fmtlen = strext (line, ip, " \t", YES, format, SZ_LINE) if (check_format (format)) { if (strlen (format) > SZ_FORMAT - 1) { call eprintf ("(%s) - Warning: Format too long (skipped)\n") call pargstr (line) next } } else { call eprintf ( "(%s) - Warning: Bad format (skipped)\n") call pargstr (line) next } # Do final adjustemnts to keyword and format and store # them into the tables if (nkeywords < MAX_TABLE) { nkeywords = nkeywords + 1 call salloc (key_table[nkeywords], SZ_KEYWORD + 1, TY_CHAR) call strcpy (keyword, Memc[key_table[nkeywords]], SZ_KEYWORD) call salloc (fmt_table[nkeywords], SZ_FORMAT + 1, TY_CHAR) call strcpy ("%", Memc[fmt_table[nkeywords]], 1) call strcat (format, Memc[fmt_table[nkeywords]], strlen (format)) opt_table[nkeywords] = format[strlen (format)] } # Debug output (true -> debug active) if (false) { call eprintf ("keyword = <%s> format = <%s> option = <%c>\n") call pargstr (Memc[key_table[nkeywords]]) call pargstr (Memc[fmt_table[nkeywords]]) call pargc (opt_table[nkeywords]) } } # Close format file call close (ffd) end # CHECK_FORMAT - Verify the syntax of a format string. It returns true if # it's a legal format and false if not. A default format code is appended # to the format if it's missing. bool procedure check_format (format) char format[ARB] # format to parse char ch # last character int n # character index int state # parser state begin n = 1 state = 0 repeat { ch = format[n] switch (state) { case 0: if (ch == EOS || ch == '#') { call strcat ("s", format, ARB) return true } else if (ch == '.') { state = 2 n = n + 1 } else if (ch == '-') { state = 1 n = n + 1 } else if (IS_DIGIT(ch)) state = 1 else if (IS_FORMAT(ch)) return true else return false case 1: if (ch == EOS || ch == '#') { call strcat ("s", format, ARB) return true } else if (ch == '.') { state = 2 n = n + 1 } else if (IS_DIGIT(ch)) n = n + 1 else if (IS_FORMAT(ch)) { state = 3 n = n + 1 } else return false case 2: if (ch == EOS || ch == '#') { call strcat ("s", format, ARB) return true } else if (IS_DIGIT(ch)) n = n + 1 else if (IS_FORMAT(ch)) { state = 3 n = n + 1 } else return false case 3: if (ch == EOS || ch == '#') return true else return false default: call error (0, "Illegal format parser state") } } end include # STREXT - Extract a word (delimited substring) from a string. # The input string is scanned from the given initial value until one # of the delimiters is found. The delimiters are not included in the # output word. # Leading white spaces in a word may be optionally skipped. White # spaces are skipped before looking at the delimiters string, so it's # possible to remove leading white spaces and use them as delimiters # at the same time. # The value returned is the number of characters in the output string. # Upon return, the pointer is located at the begining of the next word. int procedure strext (str, ip, dict, skip, outstr, maxch) char str[ARB] # input string int ip # pointer into input string char dict[ARB] # dictionary of delimiters int skip # skip leading white spaces ? char outstr[ARB] # extracted word int maxch # max number of chars int op int stridx() begin # Skip leading white spaces if (skip == YES) { while (IS_WHITE (str[ip])) ip = ip + 1 } # Process input string for (op=1; str[ip] != EOS && op <= maxch; op=op+1) if (stridx (str[ip], dict) == 0) { outstr[op] = str[ip] ip = ip + 1 } else { repeat { ip = ip + 1 } until (stridx (str[ip], dict) == 0 || str[ip] == EOS) break } outstr[op] = EOS return (op - 1) end # PRINT_STRING - Print a quantity as a number or string of characters. # It first tries to print the quantity with the format code specified # i.e, string, integer, real or double precission, using the format # specified. If it fails, it prints the quantity as a string. # The format is a string of the the form "%W.D" where "W" sets the field # width and "D" the number of characters or digits to print. It is almost # an FMTIO specification, except by the format code. # The format code is the equivalent of the "C" part of an FMTIO format. # It takes three possible values: "s" for strings, "d" for integers or # long integers, and "f" for real or double precission numbers. procedure print_string (line, str, format, code) char line[SZ_LINE] char str[SZ_LINE] # string to print char format[SZ_LINE] # format to use char code # format code char fmtstr[SZ_LINE] int ip, strlen(),pp long lval real rval double dval int ctol(), ctor(), ctod() begin # Build up format string call sprintf (fmtstr, SZ_LINE, "%s%c ") call pargstr (format) call pargc (code) # Print according the format specified ip = 1 pp = strlen(line) + 1 if (IS_STRING(code)) { call sprintf (line[pp], SZ_LINE, fmtstr) call pargstr (str) } else if (IS_INTEGER(code)) { if (ctol (str, ip, lval) > 0) { call sprintf (line[pp], SZ_LINE, fmtstr) call pargl (lval) } else { call sprintf (fmtstr, SZ_LINE, "%ss ") call pargstr (format) call sprintf (line[pp], SZ_LINE, fmtstr) call pargstr (str) } } else if (IS_FLOAT(code)) { if (ctor (str, ip, rval) > 0) { call sprintf (line[pp], SZ_LINE, fmtstr) call pargr (rval) } else if (ctod (str, ip, dval) > 0) { call sprintf (line[pp], SZ_LINE, fmtstr) call pargd (dval) } else { call sprintf (fmtstr, SZ_LINE, "%ss ") call pargstr (format) call sprintf (line[pp], SZ_LINE, fmtstr) call pargstr (str) } } else call error (0, "Internal error while processing format") end # PRINT_TITLES - Print all the keywords in the table, in the same order they # have in the table, with the corresponding formats from the format table. # A newline is printed at the end of the titles (keywords) procedure print_titles int i, ip, junk char width[SZ_LINE], format[SZ_LINE], dict[SZ_LINE] char line[SZ_LINE] include "dfits.com" int strext() begin # Print all the keywords in the title line line[1] = EOS do i = 1, nkeywords { # Build format ip = 2 call sprintf (dict, SZ_LINE, "%s.") call pargstr (FORMAT_DICT) junk = strext (Memc[fmt_table[i]], ip, dict, YES, width, SZ_LINE) call sprintf (format, SZ_LINE, "%%%s.%s") call pargstr (width) call pargstr (width) # Print title or debug code (true -> debug active) if (false) { call printf ("keyword = <%s> format = <%s> title = <") call pargstr (Memc[key_table[i]]) call pargstr (format) call print_string (line, Memc[key_table[i]], format, "s") call printf (">\n") call flush (STDOUT) } else call print_string (line, Memc[key_table[i]], format, "s") } # Print a newline at the end of the title line call printf ("%80.80s\n") call pargstr (line) end fitsutil-2018.07.06/src/doc/000077500000000000000000000000001332007674300153235ustar00rootroot00000000000000fitsutil-2018.07.06/src/doc/fgread.hlp000066400000000000000000000045571332007674300172730ustar00rootroot00000000000000.help fgread Sep99 fitsutil .ih NAME fgread -- MEF file dearchiver .ih USAGE fgread input list output .ih PARAMETERS .ls input Multiextension FITS file (MEF). .le .ls list List or range of extensions numbers to extract. To get a listing of the MEF file to find out the exact numbering, please use 'fgread extract=no'; this output listing is the one to use. Other listing like 'fxheader' should not be use since they will expand the MEF FILE, giving a larger running numbering. .le .ls output List of filenames to extract .le .ls verbose = yes Print information about each input file processed. .le .ls extract = yes Extract the listed extension from the input MEF .le .ls replace = yes Replace existing files .le .ls types = "" Select input filenames by file type. The possible types are: .nf t: text b: binary d: directory s: symbolic link f: single FITS file m: Multiple Extension FITS file (MEF) .fi The default value is to select all types. .le .ls exclude = "" Exclude input filenames by file type. The file type are the same as above. Default action is to not exclude any type. .le .ls checksum = no Computes CHECKSUM and DATASUM. The default value is no. If the value is 'yes' the task looks for the keyword CHECKSUM and DATASUM and then calculates the checksum for the data portion and for the whole file and compares these values with the above mentioned keywords values. For the algoritm to calculate checksum, please see: "ftp://iraf.noao.edu/misc/checksum/checksum.ps" .le .ih DESCRIPTION Fgread is the program to dearchive a MEF file created by fgwrite. Mainly FOREIGN extension are handled properly by filtering all the FG keyword and restoring the properties of the extracted file as close as possible to the original's. No count of the number of extensions is given, rather, the MEF group consist of all subsequent extensions until an EHU is encountered which starts a new file. .ih EXAMPLES 1) Restore extension 2 and 5 from the MEF file 'mef.fits'. First look at listing for the exact extension numbers. .nf cl> fgread mef.fits "" "" extract- cl> fgread mef.fits 2,5 "" Notice the double quote symbols to indicate a null list of output files since we want to extract extension 2 and 5. .fi 2) Extract 'log1.txt', 'log2.txt' and 'obs23.fits' extensions from the input MEF file. cl> fgread mef.fits "" log1.txt,log2.txt,obs23.fits .ih BUGS .ih SEE ALSO fgwrite .endhelp fitsutil-2018.07.06/src/doc/fgwrite.hlp000066400000000000000000000107621332007674300175050ustar00rootroot00000000000000.help fgwrite Sep99 fitsutil .ih NAME fgwrite -- File archiver in FITS file .ih USAGE fgwrite input output .ih PARAMETERS .ls input [string] List of filenames to be archive in the output FITS file. .le .ls output [string] Output Multiextension FITS file. .le .ls verbose = yes Print information about each input file processed. .le .ls group = "" The value of the FITS keyword FG_GROUP. It applies to all the FITS extensions in the MEF file. Its default value is the name of the current working directory. .le .ls types = "" Select input filenames by file type. The possible types are: .nf t: text b: binary d: directory s: symbolic link f: single FITS file m: Multiple Extension FITS file (MEF) .fi The default value is to select all types. .le .ls exclude = "" Exclude input filenames by file type. The file type are the same as above. Default action is to not exclude any type. .le .ls phu = yes Creates a Primary header unit (PHU). This is just a dummy header unit with no data to comply with a regular MEF structure file. A value of 'no' will create a MEF file without a PHU. .le .ls checksum = no Computes CHECKSUM and DATASUM. The default value is no. If the value is 'yes' the task creates the keyword CHECKSUM with the checksum for the entire FITS unit as value and DATASUM keyword with the checksum of the data portion of the unit as value. For a description and algorithm that calculates these values please look in: "ftp://iraf.noao.edu/misc/checksum/checksum.ps" .le .ls toc = no Creates a table of content in the PHU. There is one line descriptor per input file. Here is a simple example: .nf Counter offset size type level filename 1 1 1 ft 1 m.c 2 3 1 fb 1 t.o - 'offset' is the beginning of the extension header in units of 2880 bytes. - 'size' is the size of the input file in units of 2880 bytes. - 'type' is the input filename type. The 2 character pnemonic describes the kind of input file; 'f' is for FOREIGN FITS Xtension type and the second character is the type define above in 'types' parameters description. If the input file is a MEF file the 'type' is one character: 'i' IMAGE, 't' TABLE, 'b' BINTABLE, 'f' FOREIGN and 'o' for OTHER FITS XTENSION types. - 'level' is the directory depth in which the input file is located. - 'filename' is the input filename. .fi .le .ih DESCRIPTION Fgwrite is a program to encapsulate one file into a wrapper FITS Xtension called FOREIGN. If the input list has more than one input file, a MEF (Mutiple Extension FITS) file is created with one FOREIGN extension per input file. To accurately describe the input file within the FOREIGN extension, a set of FG keywords is created in the extension header in such a way that an extraction of the file is possible with all its properties restore. The FG keyword present in the FOREIGN extension header are: .ls FG_GROUP The group name that associates all of the elements of the MEF file. The group name is arbitrary and is assigned by the user when the file group is written. .le .ls FG_FNAME The filename of the file associated with the current extension. The maximum filename lenght is 67 characters. For an extension of type foreign where the file type is a directory, FNAME is the name of the directory. .le .ls FG_FTYPE The physical file type ('text', 'binary', 'directory', or 'symlink'), or for native FITS extension, the FITS type ('FITS' or 'FITS-MEF'). In the case of FITS-MEF, the EHU is the first element of a MEF group. No count of the number of extensions is given, rather, the MEF group consist of all subsequent extensions until an EHU is encountered which starts a new file. .le .ls FG_LEVEL The directory nesting level. All of the files in a directory are at the same level. Level 1 is the root directory level. .le .ls FG_FSIZE The size in bytes of the input disk file. .le .ls FG_FMODE The file mode as a string ('rwx-rwx-rwx'). .le .ls FG_FUOWN The file UID (user ID) as the file owner name string .le .ls FG_FUGRP The file GID (group ID). .le .ls FG_CTIME The file creation GMT time. .le .ls FG_MTIME The file modification GMT time. .le .ih EXAMPLES 1) Creates a MEF file 'mef.fits' with the default setup. cl> fgwrite file1.for,test.c,obs.log mef.fits 2) Create an archive of the current directory and its subdirectories excluding any symbolic links. cl> fgwrite . ../zzd_arc.fits exclude=s checksum=yes The ckecksum option is set, so the keyword CHECKSUM, DATASUM and CHECKVER will be present in all unit headers. .ih BUGS .ih SEE ALSO fgread .endhelp fitsutil-2018.07.06/src/doc/funpack.hlp000066400000000000000000000023261332007674300174620ustar00rootroot00000000000000.help funpack August09 fitsutil .ih NAME funpack -- Uncompress a list of tile compressed FITS files. .ih USAGE funpack images .ih PARAMETERS .ls images A list of tile compressed FITS images (with '.fz' extensions). .le .ls keep = no Preserve the input images? By default the input files will be replaced by the corresponding tile compressed FITS files. .le .ls listonly = no List the types and contents (FITS HDUs) of the input files? .le .ls verbose = yes Print each operation as it takes place? Data volume and timing will also be reported. .le .ls gzip = no Recompress output files with host gzip command? .le .ls nimages [Output] The number of images in the input list. .le .ih DESCRIPTION Funpack will uncompress a list of tile compressed FITS files. The input file names must have ".fz" appended. The output files will be standard FITS image files, either single images or MEFs. Optionally, the output files may be recompressed using the host gzip command. This task is a wrapper script for the CFITSIO funpack command. .ih EXAMPLES .nf 1. Uncompress a tile compressed file: im> funpack file3.fits.fz The output file is: file3.fits .fi .ih BUGS .ih SEE ALSO ricepack, http://heasarc.gsfc.nasa.gov/fitsio/fpack .endhelp fitsutil-2018.07.06/src/doc/fxconvert.hlp000066400000000000000000000063251332007674300200540ustar00rootroot00000000000000.help fxconvert Sept97 fitsutil .ih NAME fxconvert -- Convert images from one format to another .ih USAGE fxconvert input output .ih PARAMETERS .ls input Images to be copied. .le .ls output Output images or directory. .le .ls verbose = yes Print each operation as it takes place? .le .ih DESCRIPTION Fxconvert is a take from the 'imcopy' task but with the capability to convert many 'imh' images for example to 'fits' images onto an output directory. Each of the input images, which may be given as a general image template including sections, is copied to the corresponding output image list, which may also be given as an image template, or the output directory. If the output is a list of images then the number of input images must be equal to the number of output images and the input and output images are paired in order. If the output image name exists and contains a section then the input image (provided it is the same size as the section) will be copied into that section of the input image. If the output image name does not have a section specification and if it is the same as the input image name then the input image is copied to a temporary file which replaces the input image when the copy is successfully concluded. Note that these are the only cases where clobber checking is bypassed; that is, if an output image name is not equal to the input image name or a subsection of an existing image and the file already exists then a clobber error will occur if clobber checking is in effect. The verbose options prints for each copy lines of the form: .nf input image -> output image .fi .ih EXAMPLES 1. For a simple copy of an image. Since we are not putting extension, we need to which kind of image we want as output: .nf cl> reset imtype=fits cl> flpr # Necessary when changing imtype value cl> fxconvert image imagecopy .fi 2. To copy a portion of an image: cl> fxconvert image[10:20,*] subimage.fits 3. To copy several images. The 'imtype' setting is necessary to dot it only once until another image type is desire as output. After the reset, a 'flprc' command is necessary for the change to take effect. .nf cl> reset imype=fits cl> flprc cl> fxconvert image1,image2,frame10 a,b,c .fi 4. To trim an image: cl> fxconvert image[10:20,*] image In the above example the specified section of the input image replaces the original input image. To trim several images using an image template: cl> fxconvert frame*[1:512,1:512] frame* In this example all images beginning with "frame" are trimmed to 512 x 512. 5. To copy a set of images to a new directory. Notice that the output image type will be whatever the value of imtype is, and it will not necessarily be the input type. .nf cl> fxconvert image* directory or cl> fxconvert image* directory$ or cl> fxconvert image* osdirectory .fi where "osdirectory" is an operating system directory name (i.e. /user/me in UNIX). 6. To copy a section of an image in an already existing image of sufficient size to contain the input section. .nf cl> fxconvert image[1:512,1:512] outimage[257:768,257:768] .fi .ih SEE ALSO imcopy .ih BUGS The distinction between copying to a section of an existing image and overwriting a input image is rather inobvious. .endhelp fitsutil-2018.07.06/src/doc/fxcopy.hlp000066400000000000000000000031601332007674300173400ustar00rootroot00000000000000.help fxcopy May97 fitsutil .ih NAME fxcopy -- Generic FITS multi-extension copy utility .ih USAGE fxcopy input output groups .ih PARAMETERS .ls input [string] Can be a list of FITS filename or just one name if you are extracting extensions from it. Filename extensions are require. .le .ls output [string] Output filename. .le .ls groups = "" [string] Specify the list of extensions from the input file to be copied to the output file; this list follows the syntax of the ranges utilities; i.e. things like 1,2,3; 1-9 or 9,7,13,1-4 are acceptable. Also '0' to represent the Primary FITS unit is accepted. .le .ls new_file = yes Speficify whether to create a new output file or if new_file is 'no' to overwrite an existent one. .le .ls verbose = yes Print each operation as it takes place? .le .ih DESCRIPTION Fcopy is an extension to the 'imcopy' command allowing many input FITS files or selected extensions to be appended to an output FITS file. FITS extensions are numbered from zero -as the primary unit, with one as the first extension two as the second extension and so on. .ih EXAMPLES 1. To put together all of the FITS files starting with 'f' into one new output file. im> fxcopy f*.fits bigf.fits new_file=yes 2. To copy extensions 1,3,5 from input file g10.fits into a new file. If you want to append to an existent file, set 'new_file = no'. im> fxcopy g10.fits g3.fit groups="1,3,5" new_file=yes 3. Selected extensions from various input files. im> fxcopy fa.fits[2],fb.fits[5],fb.fits[7] fall.fits .ih BUGS Fxcopy does not accept sections in the filename nor extension numbers. .ih SEE ALSO imcopy, fxheader .endhelp fitsutil-2018.07.06/src/doc/fxdelete.hlp000066400000000000000000000024501332007674300176310ustar00rootroot00000000000000.help fxdelete July97 fitsutil .ih NAME fxdelete -- Generic FITS multi-extension delete utility .ih USAGE fxdelete input_list groups .ih PARAMETERS .ls input [string] Can be a list of FITS filenames with or without extension number. .le .ls groups = "" [string] Specify the list of extensions to delete from the those files without explicit extension number. This list is applied to all input files. .le .ls verbose = yes Print each operation as it takes place? .le .ih DESCRIPTION Fdelete will delete one or more FITS units in place from a Multiple extension file or a list of files. FITS extensions are numbered from zero -as the primary unit, with one as the first extension two as the second extension and so on. .ih NOTES Notice that if you delete the PHU (group zero), fxdelete will not create a dummy PHU on the modified file. .ih EXAMPLES .nf 1. Delete group 3 from input.fits. im> fxdelete input.fits[3] 2. To delete extensions 1,3,5 from input file g10.fits. im> fxdelete g10.fits groups="1,3,5" 3. Delete extensions. Notice that for those files without an extension, the group extension list applies. im> fxdelete fa.fits,fb.fits[5],fc.fits groups="1,3,4" .fi .ih BUGS Fdelete does not accept EXTNAME or EXTVER values yet. Cannot delete PHU (group 0). .ih SEE ALSO imcopy, fxheader .endhelp fitsutil-2018.07.06/src/doc/fxdummyh.hlp000066400000000000000000000013511332007674300176710ustar00rootroot00000000000000.help fxdummyh August97 fitsutil .ih NAME fxdummyh -- Create a dataless PHU. .ih USAGE fxdummyh filename .ih PARAMETERS .ls filename [string] The name of your new dataless (NAXIS=0) FITS file. .le .ls hdr_file [string] The name of your input ascii file containing a FITS like set of keywords and values. Each line needs to be standard FITS header keyword of up to 80 character long per card. The task will take care of padding each card to 80 characters. .le .ih DESCRIPTION Fxdummyh will create a dataless Primary FITS file with an optional user header information. .ih EXAMPLES .nf 1. Create a new dataless FITS file with user FITS header file. im> fxdummyh file3.fits hdr_file=myhdr.txt .fi .ih BUGS .ih SEE ALSO fxcopy,imcopy .endhelp fitsutil-2018.07.06/src/doc/fxextract.hlp000066400000000000000000000033561332007674300200470ustar00rootroot00000000000000.help fxextract Sep99 fitsutil .ih NAME fxextract -- Generic FITS multi-extension extraction utility .ih USAGE fxextract input output groups .ih PARAMETERS .ls input [string] Can be a list of FITS filename or just one name if you are extracting extensions from it. Filename extensions are require. .le .ls output [string] Output filename or directory. The root name of this filename is used if more than one extension is extracted followed by the group number. .le .ls groups = "" [string] Specify the list of extensions from the input file to be extracted to the output file or directory; this list follows the syntax of the ranges utilities; i.e. things like 1,2,3; 1-9 or 9,7,13,1-4 are acceptable. Also '0' to represent the Primary FITS unit is accepted. .le .ls use_extnm = no Speficify whether to use the value of the header keyword EXTNAME as the name of the output filename. If the keyword does not exist in the input header, the output root name is used instead. .le .ls phu = yes Creates a dummy Primary Header unit for each of the extracted extensions. If the value is 'no', the input extension is copied verbatim to the output file. .ls verbose = yes Print each operation as it takes place? .le .ih DESCRIPTION Fextract is an extension to the 'imcopy' command allowing one or more extensions from the same MEF file to be extracted into different output files. FITS extensions are numbered from zero -as the primary unit, with one as the first extension two as the second extension and so on. .ih EXAMPLES 1. To extract extension 2,4,5 from a file and not produce a PHU for each of them. The output files will be extf2.fits, extf4.fits and extf5.fits. im> fxextract mef.fits extf.fits groups=2,4,5 phu=no .ih BUGS .ih SEE ALSO imcopy, fxsplit .endhelp fitsutil-2018.07.06/src/doc/fxheader.hlp000066400000000000000000000101251332007674300176150ustar00rootroot00000000000000.help fxheader May97 fitsutil .ih NAME fxheader -- Produce a listing of a FITS file .ih USAGE fxheader input file_list .ih PARAMETERS .ls input [file name template or device specification] The FITS data source. This is either a template describing a list of disk files. .le .ls (long_header = no) [boolean] Print the full FITS header on the standard output? .le .ls (count_lines = no) [boolean] Precede each line with a count. .le .ls (short_header = yes) [boolean] Print only a short header? Lists files processed, their dimensions, size of data type and scaling parameter on the standard output. .ih DESCRIPTION This task quickly lists one or a group of FITS files on disk. It reads only the header portion of each file, skipping the data. An optional parameter allows the user to list the full FITS header rather than a single line per file. For FITS files with extensions, you can specify the extension number to get a listing of one FITS unit. The keywords below represent the standard single line of information per processed file. You can change this by suplying a filename to the parameter 'format_file'. Up to 80 characters per line are sent to the display terminal. The following information will be listed in short headers by default. The first column is a name of an image header keyword or a special name the program will process to give you the requested column information. .nf EXT# Extension number EXTTYPE Input FITS diskname. EXTNAME EXTNAME value BITPIX Bits per pixels of the input data and the original datatype. (I,R,D,U,S) DIMENS Input FITS file dimensionality. BZERO Zero offset BSCALE Scale factor Notes: (I,R,D,U,S) refer to Integer, Real, Double, Unsigned and Short input data types, respectively. If the 'ieee' parameter is set, a minus (-) sign appears between the letter and the bits figure. .fi 'DIMENS' is the number of dimensions in the output FITS file; the format is "NxNxN" If the input file is a table, this keyword indicates the number of columns (Fields) and the number of rows in the table with the suffix F and R (e.g., 27Fx12R). .le .ls (format_file = '') [file name] If you want to define your own output format--still limited to one line per file--you can create an ASCII text file with some of the special keywords, in addition to your own image header keyword that you want to see in the display terminal or in the log file. The format of the 'format' file is as follow. One column with the keywords and a second with the field width and position of the values within the columns. The column format is similar to the Fortran print formatted statement. The following special keywords are available: .nf EXT# -5.5 # (strign) Line counter (if 'long_header=no') EXTTYPE -10.10 # (string) The type of FITS unit BITPIX -5.5 # (string) Bit per pixels and (I,U,R,D,S). DIMENS -10.10 # (string) Output FITS file dimensionality. DATATYPE -8.8 # (string) Input file data type. BZERO -12.6g # (float) Scale offset value. BSCALE -12.6g # (float) Scale value. NBC -3.3 # (string) Number of cards available to insert # in header before expansion is mandatory. .fi In addition to these specials keywords, you can add your own that match the ones in the input FITS header. .le .ih EXAMPLES 1. Catalog a set of FITS extensions and FITS files. .nf fi> fxheader f1[3],gen.fit[4],bigf .fi 2. Catalog a list of FITS files whose root is 'fits' with long output and put a line count. .nf fi> fxheader fits* long+ count+ .fi 3. Catalog a FITS file with the extension number. .nf fi> fxheader yfile.fits[3] .fi will list the 3rd extension (The primary FITS unit is [0]). 4. To use an alternate format file. .nf fi> fxheader mef.fits[3] format=home$myformat.mip .fi There is also an alternative format file in fitsutil$format_off.mip that will list the header and pixel offset in byte units. .ih BUGS The 'NX' and 'NY' fields are 4 characters wide. A "*" character will be printed if the value in either field is greater than 9999. Use long headers in this case. .ih SEE ALSO tables/fitsio/catfits, rfits .endhelp fitsutil-2018.07.06/src/doc/fxinsert.hlp000066400000000000000000000025351332007674300176770ustar00rootroot00000000000000.help fxinsert July97 fitsutil .ih NAME fxinsert -- Generic FITS multi-extension insert utility .ih USAGE fxinsert input output groups .ih PARAMETERS .ls input [string] Can be a list of FITS filenames with or without extension number. .le .ls output [string] Output filename. The extension number after which the input units are going to be inserted is required. .le .ls groups = "" [string] Specify the list of extensions to insert from the those files without explicit extension number. This list is applied to all input files. .le .ls verbose = yes Print each operation as it takes place? .le .ih DESCRIPTION Finsert will insert one or more FITS units after a specified extension number from the output file. A unit can be a whole FITS file or one extension. FITS extensions are numbered from zero -as the primary unit, with one as the first extension two as the second extension and so on. .ih EXAMPLES .nf 1. Insert group 3 from input.fits after group 1 from output.fits file. im> fxinsert input.fits[3] output.fits[1] 2. To insert extensions 1,3,5 from input file g10.fits after group 5 from g30.fits file. im> fxinsert g10.fits g30.fits[5] groups="1,3,5" 3. Insert files and extensions. im> fxinsert fa.fits,fb.fits[5],fc.fits foutput.fits[3] .fi .ih BUGS Finsert does not accept EXTNAME or EXTVER values yet. .ih SEE ALSO imcopy, fxheader .endhelp fitsutil-2018.07.06/src/doc/fxplf.hlp000066400000000000000000000020251332007674300171460ustar00rootroot00000000000000.help fxplf March00 fitsutil .ih NAME fxplf -- Convert a mask or pixel list file into a FITS extension .ih USAGE fxplf input output .ih PARAMETERS .ls input [string] Can be a list of 'pl' filenames or just one pl file. .le .ls output [string] Output FITS filename. .le .ls verbose = yes Print each operation as it takes place? .le .ih DESCRIPTION Fxplf will create a new BINTABLE extension on a new or existent FITS file. The 'pl' data is located in the 'heap' area of the extension and the BINTABLE data consists of one entry with 2 integers. The first integer is the number of 16bits integers in the heap and the second is the offset from the last BINTABLE data block. If the output FITS file does not exist, a dummy primary FITS header is created before appending the BINTABLE extension. .ih EXAMPLES 1. To put together all of the Pixel list files starting with 'f' into one new output FITS file. im> fxplf f*.pl bigplf.fits .ih BUGS Fxcopy does not accept sections in the filename nor extension numbers. .ih SEE ALSO .endhelp fitsutil-2018.07.06/src/doc/fxsplit.hlp000066400000000000000000000014321332007674300175210ustar00rootroot00000000000000.help fxsplit August97 fitsutil .ih NAME fxsplit -- Split a MEF file into single FITS files. .ih USAGE fxsplit input_list .ih PARAMETERS .ls input [string] Can be a list of FITS filenames. Output names will have the input root name plus a count. .le .ls verbose = yes Print each operation as it takes place? .le .ih DESCRIPTION Fxsplit will split a FITS file with multiple extensions into individual FITS files. The output file names are similar to the input file but they will have a count number appended to the root name. .ih EXAMPLES .nf 1. Split a MEF file that have 2 extensions. im> fxsplit file3.fits The output file are: file30.fits, file31.fits file32.fits 2. To split 2 or more MEF files. im> fxsplit g10.fits,msc.fits .fi .ih BUGS .ih SEE ALSO fxcopy,imcopy .endhelp fitsutil-2018.07.06/src/doc/ricepack.hlp000066400000000000000000000115771332007674300176240ustar00rootroot00000000000000.help ricepack August09 fitsutil .ih NAME ricepack -- Tile compress a list of FITS files using the Rice algorithm. .ih USAGE ricepack images .ih PARAMETERS .ls images A list of images. The input may be FITS or MEF FITS, or either of these gzip-compressed ('.gz'), or may be IRAF '.imh' images. .le .ls keep = no Preserve the input images? By default the input files will be replaced by the corresponding tile compressed FITS files. .le .ls listonly = no List the types and contents (FITS HDUs) of the input files? .le .ls verbose = yes Print each operation as it takes place? Data volume and timing will also be reported. .le .ls quantization = 16 Floating point pixels will be quantized (see discussion below) to the background noise divided by the \fBquantization\fR parameter. .le .ls nimages [Output] The number of images in the input list. .le .ih DESCRIPTION The RICEPACK task will compress a list of images. The input may be FITS or MEF FITS, may be gzip compressed copies of either type of FITS files, or may be IRAF ".imh" images. The output file names will be compressed FITS with ".fits.fz" appended. This task is a wrapper script for the CFITSIO fpack command (see [1]). RICEPACK implements the FITS tile compression standard[3]. This well established FITS convention has several features that make it preferable to host file compression such as gzip: 1) Rectangular image tiles are separately compressed to preserve rapid random access to the image pixels. 2) The FITS headers remain uncompressed for ease of read/write access. 3) Individual FITS image extensions (HDUs) are compressed separately. FITS tile compression supports multiple compression algorithms. The IRAF RICEPACK task by default implements Rice compression. Compression of integer-valued images will be lossless. The Rice algorithm realizes a near optimal compression factor[2] and is much faster than alternatives like gzip. Example 2 describes how to override the choice of algorithm using the \fBflags\fR parameter. The \fBkeep\fR parameter offers the option of retaining the original input files. By default the IRAF RICEPACK task replaces the input files with the output compressed files (else the action of compressing the image list would actually consume additional diskspace). This is different than the default behavior of the CFITSIO fpack command. The \fBlistonly\fR and \fBverbose\fR control the amount of information listed. If \fBlistonly\fR is set to yes, the input data files will remain untouched and no compressed output will be created. If \fBverbose\fR is set to no, the task will operate silently. The number of images processed will be reported on output as the value of the \fBnimages\fR parameter. .ih FLOATING POINT HANDLING The compression of floating point data presents a notorious challenge. This is as true for astronomical data as for any other. Compression ratios are typically small for such data. At the same time, floating point data often retain unwarranted false precision. For example, if the input of a standard CCD processing pipeline is 16-bit integers, then generating 32-bit output is to claim roughly double the precision intrinsic to the raw data. A widely adopted solution is to rescale the floating point data into an integer range more appropriate to the actual data. The RICEPACK task accomplishes this using the \fBquantization\fR parameter, which represents the number of levels into which the measured one-sigma background will be divided. The default value of 16 (see [2] and included references) has been shown to have a negligible effect (for typical purposes) on derived photometric and astrometric results. Also, bear in mind that the poisson statistics of most astronomical detectors means that sampling the background noise into 16 such bins may result in oversampling the bright end of the dynamic range by a factor of several hundred. .ih EXAMPLES .nf 1. Tile compress a file using the default Rice algorithm fitsutil> ricepack file3.fits The output file is: file3.fits.fz 2. Compress a mixed list of images: fitsutil> ricepack *.fits,*.imh,*.fits.gz 3. Compress a file and retain the original: fitsutil> ricepack file4.fits keep+ 4. Uncompress gzipped files and recompress using Rice in one step: fitsutil> ricepack *.gz 1.1.3 (March 2009) CFITSIO version 3.140 Wed 15:31:50 19-Aug-2009 kp1016311.fits.gz -> kp1016311.fits.fz ... kp1016429.fits.gz -> kp1016429.fits.fz Wed 15:31:58 19-Aug-2009 63 images, 0.13 seconds each, 0:00:08.0 elapsed input: 56.550 MB output: 45.701 MB saved: 10.849 MB, 19% relative R = 1.24 .fi The Rice compressed files save 19% of the space (10.849 MB in this case) required for the gzip files; the relative compression ratio is 1.24 (output/input). .ih SEE ALSO funpack .ih REFERENCES [1] http://heasarc.gsfc.nasa.gov/fitsio/fpack [2] http://arxiv.org/abs/0903.2140 [3] http://fits.gsfc.nasa.gov/registry/tilecompression.html .endhelp fitsutil-2018.07.06/src/doc/sum32.hlp000066400000000000000000000025141332007674300170030ustar00rootroot00000000000000.help sum32 September09 fitsutil .ih NAME sum32 -- Compute the 1's complement checksum for a list of files. .ih USAGE sum32 input .ih PARAMETERS .ls input [string] A list of files, often but not exclusively FITS images. .le .ls verbose = no Report verbose information for each file? .le .ls nimages [Output] The number of images in the input list. .le .ih DESCRIPTION SUM32 computes the 32-bit 1's complement checksum for a list of files. This is the algorithm used for the standard FITS checksum [1]. Any 32-bit checksum will generate a 10 digit hash value. The special feature of the 1's complement checksum is that this hash is straightforward to invert (and thus is not suited to protect against explicit mischief). Since the checksum can be computed, it is possible to force a file's checksum to a specific value. Without this feature it would be impossible to convey a checksum within the original file. Files (typically FITS) that have been so treated will be reported as "sum_zeroed" in the task output. The file size in bytes is also reported. .ih EXAMPLES .nf 1. Report the 1's complement checksum for a list of files: fitsutil> sum32 *.fits sum_zeroed 584640 test1.fits.fz 1363490151 532800 test2.fits 2002849261 172800 test3.fits .fi .ih REFERENCES [1] http://fits.gsfc.nasa.gov/registry/checksum.html .endhelp fitsutil-2018.07.06/src/fgread.c000066400000000000000000000504261332007674300161610ustar00rootroot00000000000000/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. */ #include #include #include #include #include #include #include /* #include */ #ifdef SYSV #include #else #include #include #endif #if defined(MACOSX) || defined(__linux) #include #endif #include "kwdb.h" static long get_timezone(); /* * FGREAD -- Read a MEF FITS file created by fgwrite. * * Switches: * d print debug messages * f read from named file rather than stdin * n get list of extension numbers to extract * o omit the indicated FITS types (tbdsfm) * t: text, b: binary, d: directory, s: symlink, * f: FITS, m: FITS-MEF. * r replace existing file at extraction * s check CHECKSUM if keywords are present * t include the indicated FITS types (tbdsfm) only * v verbose; print full description of each file * x extract files * * Usage: "fgread [-t ] [-o ] [-n ranges] [-vdxrf] * [-f fitsfile [files]". * where 'ranges' is of the form: 2,4,7-9,12-14,23 (no spaces * allow in between). * * fgread -xvf fgfile.fits log12.txt kp01.fits rf_mos.hd * * would extract the listed files from input gffile.fits. If the list is * empty, all the FITS extensions from the input file will be extracted. * * fgread -n 2,5,9-12,16 -xvf fgfile.fits * * would extract the FITS extension numbers indicated in the list. The list * should not have imbedded spaces. */ #define FBLOCK 2880 #define NBLOCK 20 #define NAMSIZ 100 #define CARDLEN 80 #define SZ_OWNERSTR 48 #define SLEN 68 #define MAXLINELEN 256 #define SZ_BUFFER (FBLOCK * NBLOCK) #define EOS '\0' #define ERR (-1) #define OK 0 #define MAXENTRIES 500 #define YES 1 #define NO 0 #define BYTELEN 8 #define LF_LINK 1 #define LF_SYMLINK 2 #define LF_BIN 3 #define LF_TXT 4 #define LF_DIR 5 #define FITS 6 #define FITS_MEF 7 #define OTHER 8 /* Decoded file header. */ struct fheader { char name[NAMSIZ]; int mode; int uid; int gid; int isdir; int dirlevel; long size; long hsize; long mtime; long chksum; int linkflag; char linkname[NAMSIZ]; }; struct _modebits { int code; char ch; } modebits[] = { 0400, 'r', 0200, 'w', 0100, 'x', 040, 'r', 020, 'w', 010, 'x', 04, 'r', 02, 'w', 01, 'x', 0, 0 }; static int debug; /* Print debugging messages */ static int extract; /* Extract files from the tape */ static int replace; /* Replace existing files */ static int printfnames; /* Print file names */ static int verbose; /* Print everything */ static int eof; static int nerrs; static char *file_list; static int nblocks; static int dlevel; /* Directory level (1 == top) */ int sums = NO; /* Do not do checksum */ int count; int omittxt=NO; /* omit text files */ int omitbin=NO; /* omit binary files */ int omitdir=NO; /* omit directory files */ int omitsymlink=NO; /* omit symbolic links */ int omitfits=NO; /* omit FITS files */ int omitfitsmef=NO; /* omit FITS-MEF files */ unsigned short sum16; unsigned int sum32; /* MAIN -- "rtar [xtvlef] [names]". The default operation is to extract all * files from the tar format standard input in quiet mode. */ main (argc, argv) int argc; char *argv[]; { struct fheader fh; char **argp; char *s, *ip, *p, type[20]; char ascii[161]; int in = 0, out, omitx; int ftype, ch, ncards, xarr[100], xcount; int epos,in_off,nbytes; pointer kwdb; int stat, list; debug = 0; extract = 0; replace = 0; printfnames = 0; verbose = 0; omitx = NO; xarr[1] = -1; /* Get parameters. Argp is left pointing at the list of files to be * extracted (default all if no files named). */ argp = &argv[1]; if (argc <= 1) extract++; else { while (*argp && **argp == '-') { ip = *argp++ + 1; while ((ch = *ip++) != EOS) { switch (ch) { case 'x': extract++; break; case 'd': debug++; break; case 'r': replace++; break; case 's': sums = YES; break; case 'v': printfnames++; verbose++; break; case 'o': /* Omit filetypes */ omitx = YES; for (p = *argp; *p != EOS; p++) { if (*p == 't') omittxt = YES; if (*p == 'b') omitbin = YES; if (*p == 'd') omitdir = YES; if (*p == 's') omitsymlink = YES; if (*p == 'f') omitfits = YES; if (*p == 'm') omitfitsmef = YES; } *argp++; break; case 't': /* Include filetypes */ omittxt = YES; omitbin = YES; omitdir = YES; omitsymlink = YES; omitfits = YES; omitfitsmef = YES; omitx = YES; for (p = *argp; *p != EOS; p++) { if (*p == 't') omittxt = NO; if (*p == 'b') omitbin = NO; if (*p == 'd') omitdir = NO; if (*p == 's') omitsymlink = NO; if (*p == 'f') omitfits = NO; if (*p == 'm') omitfitsmef = NO; } *argp++; break; case 'n': /* Get list of extension numbers to read */ get_range (*argp, xarr); *argp++; break; case 'f': if (*argp == NULL) { fprintf (stderr, "missing filename argument\n"); exit (1); } in = open (*argp, 0); if (in == ERR) { fprintf (stderr, "cannot open `%s'\n", *argp); exit (1); } argp++; break; default: fprintf (stderr, "Warning: unknown switch `%c'\n", ch); fflush (stderr); exit (1); } } } } /* read PHU first */ kwdb = kwdb_Open("PHU"); ncards = kwdb_ReadFITS (kwdb, in, MAXENTRIES, NULL); if (kwdb_Lookup (kwdb, "SIMPLE",0) == 0) { /* We have a FITS file with no PHU, rewind */ lseek (in, 0L, SEEK_SET); } kwdb_Close (kwdb); file_list = *argp++; list = NO; if (file_list != NULL) list = YES; /* Step along through the FG FITS file. Read file header and if * extension is in list and extraction is enabled, extract extension. */ dlevel = 1; xcount = 0; count = 0; for (;;) { count++; kwdb = kwdb_Open("EHU"); stat = getheader (in, &fh, &ftype, kwdb, type); if (stat == EOF) { kwdb_Close (kwdb); break; } /* See if we need to omit types of extensions */ if (omitx) { if (omit_ftype (ftype) == YES) { skipfile (in, &fh, kwdb); kwdb_Close (kwdb); if (xarr[1] > 0) xcount++; continue; } } /* If there is a file list, look for it */ if (xarr[1] > 0) { if (xarr[xcount] < 0) break; if (xarr[xcount] != count) { skipfile (in, &fh, kwdb); kwdb_Close (kwdb); continue; } xcount++; } else if (file_list != NULL) { if (strcmp (fh.name, file_list) != 0) { skipfile (in, &fh, kwdb); kwdb_Close (kwdb); continue; } file_list = *argp++; } if (printfnames) { printheader (stdout, &fh, type); fflush (stdout); } if (ftype == LF_SYMLINK) { if (extract) { if (replace) unlink (fh.name); if (symlink (fh.linkname, fh.name) != 0) { fprintf (stderr, "Cannot make symbolic link %s -> %s\n", fh.name, fh.linkname); } } continue; } if (extract) { out = newfile (fh.name, &fh, ftype); if (out == ERR) { fprintf (stderr, "cannot create file `%s'\n", fh.name); skipfile (in, &fh, kwdb); continue; } if (!fh.isdir) { if (ftype == FITS || ftype == FITS_MEF) copyheader (out, kwdb); copyfile (in, out, &fh, ftype); close (out); if (sum32 > 0 && sums == YES) { if (debug) printf("CHECKSUM: %d\n",sum32); if (sum32 != -1 && ftype != FITS_MEF) { fprintf (stderr, "**** Checksum error in extension %d (%s)\n", count, fh.name); } } } chown (fh.name, fh.uid, fh.gid); /* set file mtime */ { struct utimbuf times; times.actime = 0L; times.modtime = fh.mtime; utime (fh.name, ×); } } else skipfile (in, &fh, kwdb); kwdb_Close (kwdb); if (list == YES && file_list == NULL) break; } if (in) close (in); exit(0); } /* GETHEADER -- Read the next file block and attempt to interpret it as a * file header. A checksum error on the file header is fatal and usually * indicates that the file was not properly transferred. */ getheader (in, fh, ftype, kwdb, type) int in; /* input file */ register struct fheader *fh; /* decoded file header (output) */ int *ftype; /* file type */ pointer kwdb; char *type; /* Extension type */ { register char *ip, *op; register int n; char smode[SLEN]; int ntrys, ncards, hsize, hpos, in_off; int nbh, bks, i, recsize; char record[FBLOCK*NBLOCK]; char *s, *p; register struct _modebits *mp; struct tm tm; int mode=0; /* get the current file position */ hpos = lseek (in, 0, SEEK_CUR); ncards = kwdb_ReadFITS (kwdb, in, MAXENTRIES, NULL); if (ncards == 0) return(EOF); sum16 = 0; sum32 = 0; fh->isdir = 0; fh->linkflag = 0; fh->hsize = 0; s = kwdb_GetValue (kwdb, "FG_FTYPE"); /* We could be reading a header from an IMAGE extension and * we will not have any of the FG keywords. */ if (s == NULL) { fh->name[0] = EOS; return (FBLOCK); } if (strncmp (s, "text", 4) == 0) *ftype = LF_TXT; else if (strncmp (s, "symlink", 7) == 0) *ftype = LF_SYMLINK; else if (strncmp (s, "binary", 6) == 0) *ftype = LF_BIN; else if (strncmp (s, "directory", 9) == 0) { *ftype = LF_DIR; fh->isdir = 1; } else if (strncmp (s, "FITS-MEF", 8) == 0) *ftype = FITS_MEF; else if (strncmp (s, "FITS", 4) == 0) *ftype = FITS; else if (strncmp (s, "other", 5) == 0) *ftype = OTHER; strcpy (type, s); s = kwdb_GetValue (kwdb, "FG_LEVEL"); fh->dirlevel = atoi(s); s = kwdb_GetValue (kwdb, "FG_FNAME"); if ((p=strchr(s,' ')) != NULL) *p = '\0'; strcpy (fh->name, s); if (*ftype == LF_SYMLINK) { strcpy (fh->name, s); strcpy (fh->linkname, p+4); fh->linkflag = 1; } s = kwdb_GetValue (kwdb, "FG_FSIZE"); fh->size = atoi(s); if (*ftype == FITS || *ftype == FITS_MEF) { /* reduce the size by the size of the FITS header * since for FITS we need to write the header out and * its size is already included in fh.size. */ hsize = ((ncards+35)/36)*2880; fh->hsize = hsize; } s = kwdb_GetValue (kwdb, "FG_FMODE"); s++; for (mp=modebits; mp->code; mp++) mode = mp->ch == *s++ ? mp->code | mode : mode; fh->mode = mode; s = kwdb_GetValue (kwdb, "FG_MTIME"); strptime (s, "%Y-%m-%dT%T",&tm); fh->mtime = mktime(&tm) - get_timezone(); s = kwdb_GetValue (kwdb, "FG_FUOWN"); get_uid (s, fh); s = kwdb_GetValue (kwdb, "FG_FUGRP"); get_gid (s, fh); in_off = lseek (in, 0, SEEK_CUR); /* Calculate header checksum only if the CHECKSUM keyword exists */ if (kwdb_GetValue (kwdb, "CHECKSUM") != NULL && sums == YES) { in_off = lseek (in, hpos, SEEK_SET); nbh = (ncards + 1 + 35)/36; /* Fblocks of header */ bks = nbh/NBLOCK; for (i=1; i<=bks; i++) { recsize = read (in, record, FBLOCK*NBLOCK); checksum (record, recsize, &sum16, &sum32); } if (nbh % NBLOCK != 0) { recsize = read (in, record, (nbh % 10)*FBLOCK); checksum (record, recsize, &sum16, &sum32); } } return (FBLOCK); } /* GET_UID -- Get the uid for a user name . */ get_uid (s, fh) char *s; register struct fheader *fh; /* decoded file header (output) */ { static int uid; static char owner[SZ_OWNERSTR+1]={'\0'}; struct passwd *pw; char *ip; /* if the input file user name is not knowm get * the current process uid. */ ip = strchr(s, ' '); if (ip != NULL) *ip = '\0'; if (!strncmp(s, "", 9)) { fh->uid = getuid(); return (0); } if (!strcmp(s,owner)) {; fh->uid = uid; return (0); } else { /* setpwent(); */ pw = getpwnam (s); /* endpwent(); */ if (pw == NULL) fh->uid = getuid(); else { strncpy (owner, s, SZ_OWNERSTR); fh->uid = pw->pw_uid; uid = pw->pw_uid; } } } /* GET_GID -- Get the gid for a user name . */ get_gid (s, fh) char *s; register struct fheader *fh; /* decoded file header (output) */ { static int gid; static char owner[SZ_OWNERSTR+1]={'\0'}; struct passwd *pw; char *ip; /* if the input file user name is not knowm get * the current process uid. */ ip = strchr(s, ' '); if (ip != NULL) *ip = '\0'; if (!strncmp(s, "", 9)) { fh->uid = getgid(); return (0); } if (!strcmp(s,owner)) {; fh->gid = gid; return (0); } else { /* setpwent(); */ pw = getpwnam (s); /* endpwent(); */ if (pw == NULL) fh->gid = getgid(); else { strncpy (owner, s, SZ_OWNERSTR); fh->gid = pw->pw_gid; gid = pw->pw_gid; } } } /* struct _modebits { int code; char ch; } modebits[] = { 040000, 'd', 0400, 'r', 0200, 'w', 0100, 'x', 040, 'r', 020, 'w', 010, 'x', 04, 'r', 02, 'w', 01, 'x', 0, 0 }; */ /* PRINTHEADER -- Print the file header in either short or long (verbose) * format, e.g.: * drwxr-xr-x 9 tody 1024 Nov 3 17:53 . */ printheader (out, fh, type) FILE *out; /* output file */ register struct fheader *fh; /* file header struct */ char *type; /* Foreign extension type, (bin, text..) */ { char *tp, *ctime(); tp = ctime (&fh->mtime); fprintf (out, "%-4d %-10.10s %9d %-12.12s %-4.4s %s", count,type, fh->size, tp + 4, tp + 20, fh->name); if (fh->linkflag && *fh->linkname) { fprintf (out, " -> %s ", fh->linkname); } fprintf(out, "\n"); } /* NEWFILE -- Try to open a new file for writing, creating the new file * with the mode bits given. Create all directories leading to the file if * necessary (and possible). */ newfile (fname, fh, ftype) char *fname; /* pathname of file */ register struct fheader *fh; /* file header struct */ int ftype; /* text, binary, director, etc */ { int fd; char *cp, *cwd, dirname[MAXLINELEN]; int i, mode, fdirlevel; mode = fh->mode; fdirlevel = fh->dirlevel; if (debug) fprintf (stderr, "newfile `%s':\n", fname); if (ftype == LF_DIR && fdirlevel >= 1) { if (fdirlevel < dlevel) { chdir ("../"); dlevel = fdirlevel; } /* See if directory has been created */ cwd = getcwd (dirname, MAXLINELEN); strcat (dirname, "/"); strcat (dirname, fname); if (access (dirname, F_OK)) { /* directory does not exist, create */ fd = mkdir (fname, mode); fd = OK; chdir (fname); dlevel++; } /* if (dlevel != fdirlevel || dlevel == 1) { chdir (fname); dlevel++; printf("chdir to '%s', fdirlevel: %d, dlevel: %d\n", fname, fdirlevel, dlevel); */ /* dlevel = fdirlevel; */ } else if (fdirlevel < dlevel) { /* we need to travel upwards */ for (i=fdirlevel; i < dlevel; i++) chdir ("../"); dlevel = fdirlevel; } if (ftype != LF_DIR) { if (replace) unlink (fname); fd = creat (fname, mode); } return (fd); } /* COPYHEADER -- Copy the PHU of a FITS or FITS-MEF extension from a * file created by fgwrite. We need to get rid of the FG_ keywords * before leaving. */ copyheader (out, kwdb) int out; /* output file */ pointer kwdb; { int ep, ncards, hdr_off, i; char card[CARDLEN]; /* Change extension to SIMPLE */ ep = kwdb_Lookup (kwdb, "XTENSION", 0); kwdb_RenameEntry (kwdb, ep, "SIMPLE"); kwdb_SetType (kwdb, "SIMPLE", "L"); kwdb_SetValue (kwdb, "SIMPLE", "T"); ep = kwdb_Lookup (kwdb, "FG_GROUP", 0); kwdb_DeleteEntry (kwdb, ep); ep = kwdb_Lookup (kwdb, "FG_FNAME", 0); kwdb_DeleteEntry (kwdb, ep); ep = kwdb_Lookup (kwdb, "FG_FTYPE", 0); kwdb_DeleteEntry (kwdb, ep); ep = kwdb_Lookup (kwdb, "FG_LEVEL", 0); kwdb_DeleteEntry (kwdb, ep); ep = kwdb_Lookup (kwdb, "FG_FSIZE", 0); kwdb_DeleteEntry (kwdb, ep); ep = kwdb_Lookup (kwdb, "FG_FMODE", 0); kwdb_DeleteEntry (kwdb, ep); ep = kwdb_Lookup (kwdb, "FG_FUOWN", 0); kwdb_DeleteEntry (kwdb, ep); ep = kwdb_Lookup (kwdb, "FG_FUGRP", 0); kwdb_DeleteEntry (kwdb, ep); ep = kwdb_Lookup (kwdb, "FG_CTIME", 0); kwdb_DeleteEntry (kwdb, ep); ep = kwdb_Lookup (kwdb, "FG_MTIME", 0); kwdb_DeleteEntry (kwdb, ep); /* Delete CHECKSUM set */ ep = kwdb_Lookup (kwdb, "CHECKSUM", 0); kwdb_DeleteEntry (kwdb, ep); ep = kwdb_Lookup (kwdb, "DATASUM", 0); kwdb_DeleteEntry (kwdb, ep); ep = kwdb_Lookup (kwdb, "CHECKVER", 0); kwdb_DeleteEntry (kwdb, ep); ncards = kwdb_WriteFITS (kwdb, out); hdr_off = ((ncards + 1 + 35)/36)*36*80; memset (card, ' ', CARDLEN); for (i = (ncards+1) % 36; i < 36; i++) write (out, card, CARDLEN); strcpy (card, "END"); memset (card+3, ' ', CARDLEN-3); write (out, card, CARDLEN); } /* COPYFILE -- Copy bytes from the input (tar) file to the output file. * Each file consists of a integral number of FBLOCK size blocks on the * input file. */ copyfile (in, out, fh, ftype) int in; /* input file */ int out; /* output file */ struct fheader *fh; /* file header structure */ int ftype; /* text or binary file */ { long nbytes, bsize; int i, nblocks; char buffer[SZ_BUFFER], *p; /* Link files are zero length on the tape. */ if (fh->linkflag) return (0); /* hsize is different from zero for FITS(-MEF) ftype only. * Also we copy the entire MEF file since its size * information is given in FG_FSIZE. */ nblocks = (fh->size - fh->hsize)/SZ_BUFFER; for (i=1; i <= nblocks; i++) { nbytes = read (in, buffer, SZ_BUFFER); if (sum32 > 0 && sums == YES) checksum (buffer, nbytes, &sum16, &sum32); if (write (out, buffer, nbytes) == ERR) { fprintf (stderr, "Warning: file write error on `%s'\n", fh->name); exit (1); } } /* read the remainder in unit of FBLOCK to leave the file * pointer correctly positioned for the next unit read. */ bsize = (fh->size - fh->hsize) % SZ_BUFFER; nbytes = ((bsize + 2879)/2880)*2880; if (bsize != 0) { nbytes = read (in, buffer, nbytes); if (sum32 > 0 && sums == YES) checksum (buffer, nbytes, &sum16, &sum32); if (write (out, buffer, bsize) == ERR) { fprintf (stderr, "Warning: file write error on `%s'\n", fh->name); } } } /* SKIPFILE -- Skip the current FITS unit up to the beginning of the * next. */ skipfile (in, fh, kwdb) int in; /* input file */ struct fheader *fh; /* file header */ pointer kwdb; { int datasize; int in_off; in_off = lseek (in, 0, SEEK_CUR); in_off = ((in_off + 2879)/2880)*2880; datasize = ((fh->size - fh->hsize + 2879)/2880)*2880; in_off = lseek (in, in_off+datasize, SEEK_SET); } /* GET_RANGE -- Parse a string with a list of ranges; e.g. 1,4,5-8,12 * and put the expanded values in the integer array. */ get_range (list, xarr) char *list; int *xarr; { int i,j,k,l, n; char *p; p= list; while (*p) { if (isdigit(*p) || *p == ',' || *p == '-') p++; else { fprintf (stderr, "Only digits, '-' and ',' allowed in list.\n"); fflush (stderr); exit (1); } } p= list; j=0; for(;;) { n = strtol(p, &p, 10); if (*p == '\0') { xarr[j++] = n; break; } else if (*p == '-') { i=n; n = strtol(++p, &p, 10); k = n; for(l=i; l<= k; l++) xarr[j++] = l; if (*p == '\0') break; p++; } else { xarr[j++] = n; p++; } } xarr[j] = -1; } /* OMIT_FTYPE -- Omit the FITS extension of type ftype */ int omit_ftype (ftype) int ftype; { switch(ftype) { case LF_SYMLINK: if (omitsymlink) return(YES); break; case LF_BIN: if (omitbin) return(YES); break; case LF_TXT: if (omittxt) return(YES); break; case LF_DIR: if (omitdir) return(YES); break; case FITS: if (omitfits) return(YES); break; case FITS_MEF: if (omitfitsmef) return(YES); break; default: return(NO); break; } return(NO); } /* _TIMEZONE -- Get the local timezone, measured in seconds westward * from Greenwich, ignoring daylight savings time if in effect. */ static long get_timezone() { #ifdef SYSV extern long timezone; tzset(); return (timezone); #else #ifdef MACOSX struct tm *tm; time_t clock = time(NULL); tm = localtime (&clock); return (-(tm->tm_gmtoff)); #else struct timeb time_info; ftime (&time_info); return (time_info.timezone * 60); #endif #endif } fitsutil-2018.07.06/src/fgread.cl000066400000000000000000000026411332007674300163310ustar00rootroot00000000000000#{ FGREAD - Procedure to start the foreign task fgread. procedure fgread (input, list, file_list) string input {prompt="Input MEF file"} string list {prompt="Extension list to extract"} string file_list {prompt="Output file list"} bool verbose=yes {prompt="verbose"} string types="" {prompt="Select filetypes (tbdsfm)"} string exclude="" {prompt="Exclude filetypes (tbdsfm)"} bool extract=yes {prompt="Extract files?"} bool checksum=no {prompt="Checksums?"} bool replace=yes {prompt="replace existing files?"} begin string lis, olis string inf="" string out="" string sel="" string excl="" string flags="" string groupn if (input != "") inf = "-f "//input lis = list olis = file_list # Look if the output is a list of files. i = 1 j = stridx (",", olis) if (j == 0) out = olis while (j > 0) { out = out//" "// substr(olis,i,j-1) olis = substr (olis, j+1,file_list.p_len) j = stridx (",",olis) if (j == 0) out = out//" "// substr(olis,i,j-1) } if (verbose == yes) flags = flags//"v" if (extract == yes) flags = flags//"x" if (replace == no) flags = flags//"r" if (checksum == yes) flags = flags//"s" if (flags != "") flags = "-"//flags if (types != "") sel = "-t "//types if (exclude != "") excl = "-o "//exclude if (lis != "") lis = "-n "//lis t_fgread (sel, excl, lis, flags, inf, out) end fitsutil-2018.07.06/src/fgwrite.c000066400000000000000000001201421332007674300163710ustar00rootroot00000000000000/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. */ #include #include #include #include #include #include #include #include #include #include #include "kwdb.h" /* * FGWRITE -- Write a MEF files with FOREIGN Xtension type. * * Switches: * f write to named file, otherwise write to stdout * d print debug messages * v verbose; print full description of each file * g FG_GROUP name. The defualt is the root directory name * t select filetypes to include in output file * o skip filestypes from input files selection * h do not produce PHU * i write Table Of Content in PHU. * s Calculate CHECKSUM and DATASUM for the input file. * * Usage: "fgwrite [-t ] [-o ] [-vdih] [-g ] * [-f output_fits_file] [input_files]". */ #define ERR -1 #define YES 1 #define NO 0 #define EOS '\0' #define SZ_PATHNAME 511 #define FBLOCK 2880 #define SLEN 68 #define TOCLEN 70 #define CARDLEN 80 #define NBLOCK 20 #define BYTELEN 8 #define NAMSIZ 100 #define MAX_TOC 100 #define SZ_OWNERSTR 48 #define MAXENTRIES 500 #define KB 1024 #define LF_LINK 1 #define LF_SYMLINK 2 #define LF_BIN 3 #define LF_TXT 4 #define LF_DIR 5 #define FITS 6 #define FITS_MEF 7 #define OTHER 8 /* Decoded file header. */ struct fheader { char name[NAMSIZ]; int mode; int uid; int gid; int isdir; long size; long mtime; long ctime; long chksum; int linkflag; char linkname[NAMSIZ]; }; /* Map file mode bits into characters for printed output. */ struct _modebits { int code; char ch; } modebits[] = { 0400, 'r', 0200, 'w', 0100, 'x', 040, 'r', 020, 'w', 010, 'x', 04, 'r', 02, 'w', 01, 'x', 0, 0 }; int debug=NO; /* Print debugging messages */ int omittxt=NO; /* omit text files */ int omitbin=NO; /* omit binary files */ int omitdir=NO; /* omit directory files */ int omitsymlink=NO; /* omit symbolic links */ int omitfits=NO; /* omit FITS files */ int omitfitsmef=NO; /* omit FITS-MEF files */ int verbose=NO; /* Print everything */ int in; int out = EOF; int count = 0; int maxcount; int toc; int sums = NO; int hdr_off; char *slines; char group[SLEN],*gname(); char *dname(); static char *str(); /* MAIN -- "fgwrite [-t ] [-o ] [-vd] [-f fitsfile] [files]". * If no files are listed the * current directory tree is used as input. If no output file is specified * output is to the standard output. */ main (argc, argv) int argc; char *argv[]; { static char *def_flist[1] = {NULL}; char *argp, **flist, *arg, *ip; pointer kwdb, kwtoc; char card[SZ_PATHNAME]; char *sline; int argno, ftype, i, ncards, level, phu; flist = def_flist; verbose = debug; group[0] = EOS; phu = YES; toc = NO; if (debug) { printf ("fgwrite called with %d arguments:", argc); for (argno=1; (argp = argv[argno]) != NULL; argno++) printf (" %s", argp); printf ("\n"); } /* Process the argument list. */ for (argno=1; (argp = argv[argno]) != NULL; argno++) { if (*argp != '-') { flist = &argv[argno]; break; } else { for (argp++; *argp; argp++) { switch (*argp) { case 'd': debug++; break; case 'v': verbose++; break; case 'h': phu = NO; break; case 'i': toc = YES; break; case 'g': /* Get GROUP name */ if (argv[argno+1]) strcpy(group, argv[++argno]); break; case 's': sums = YES; break; case 'o': /* Omit filetypes */ if (argv[argno+1]) arg = argv[++argno]; else break; for (ip = &arg[0]; *ip != EOS; ip++) { if (*ip == 't') omittxt = YES; if (*ip == 'b') omitbin = YES; if (*ip == 'd') omitdir = YES; if (*ip == 's') omitsymlink = YES; if (*ip == 'f') omitfits = YES; if (*ip == 'm') omitfitsmef = YES; } break; case 't': /* Include filetypes */ if (argv[argno+1]) arg = argv[++argno]; else break; omittxt = YES; omitbin = YES; omitdir = YES; omitsymlink = YES; omitfits = YES; omitfitsmef = YES; for (ip = &arg[0]; *ip != EOS; ip++) { if (*ip == 't') omittxt = NO; if (*ip == 'b') omitbin = NO; if (*ip == 'd') omitdir = NO; if (*ip == 's') omitsymlink = NO; if (*ip == 'f') omitfits = NO; if (*ip == 'm') omitfitsmef = NO; } break; case 'f': if (argv[argno+1]) { argno++; if (debug) printf ("open output file `%s'\n", argv[argno]); out = open (argv[argno], O_RDWR|O_CREAT|O_TRUNC, 0644); if (out == ERR) { fflush (stdout); fprintf (stderr, "cannot open `%s'\n", argv[argno]); exit (1); } } break; default: fflush (stdout); fprintf (stderr, "Warning: unknown switch -%c\n", *argp); fflush (stderr); } } } } /* Write to the standard output if no output file specified. * The filename "stdin" is reserved. */ if (out == ERR) { verbose = 0; if (debug) printf ("output defaults to stdout\n"); out = 1; } /* if no GROUP name */ if (!group[0]) { getcwd (card, SZ_PATHNAME); strcpy(group, gname(card)); } /* Write toc only of phu is not deselected */ if (phu == NO) toc = NO; /* Create Table Of Contents */ if (toc == YES) { slines = (char *) calloc (MAX_TOC, TOCLEN); ip = slines; maxcount = MAX_TOC; hdr_off = 2880; level = 1; /* Put each directory and file listed on the command line to * the fitsfile. */ for (i=0; (argp = flist[i]) != NULL; i++) if ((ftype = filetype (argp)) == LF_DIR) putfiles (argp, out, "", &level); else fgfileout (argp, out, ftype, "", level); } if (phu == YES) { /* Write PHU */ if (!(kwdb = kwdb_Open ("PHU"))) goto done; kwdb_AddEntry (kwdb, "SIMPLE", "T", "L", "File conforms to FITS standard"); kwdb_AddEntry (kwdb, "BITPIX", "8", "N", "Bits per pixel (not used)"); kwdb_AddEntry (kwdb, "NAXIS", "0", "N", "PHU contains no image matrix"); kwdb_AddEntry (kwdb, "EXTEND", "T", "L", "File contains extensions"); kwdb_AddEntry (kwdb, "ORIGIN", "NOAO Fgwrite utility May 1999", "S", ""); /* Now add the Table of Content to this PHU */ if (toc == YES) { list_toc (kwdb); free (ip); } ncards = kwdb_WriteFITS (kwdb, out); hdr_off = ((ncards + 1 + 35)/36)*36*80; memset (card, ' ', CARDLEN); for (i = (ncards+1) % 36; i < 36; i++) write (out, card, CARDLEN); strcpy (card, "END"); memset (card+3, ' ', CARDLEN-3); write (out, card, CARDLEN); kwdb_Close (kwdb); } toc = NO; count = 0; level = 1; /* Put each directory and file listed on the command line to * the fitsfile. */ for (i=0; (argp = flist[i]) != NULL; i++) if ((ftype = filetype (argp)) == LF_DIR){ putfiles (argp, out, "", &level); } else fgfileout (argp, out, ftype, "", level); /* Close the fitsfile. */ done: close (out); exit (0); } /* PUTFILES -- Put the named directory tree to the output fitsfile. We chdir * to each subdirectory to minimize path searches and speed up execution. */ putfiles (dir, out, path, level) char *dir; /* directory name */ int out; /* output file */ char *path; /* pathname of curr. directory */ int *level; /* directory level */ { char newpath[SZ_PATHNAME+1]; char oldpath[SZ_PATHNAME+1]; char fname[SZ_PATHNAME+1]; int ftype, dirl; DIR *dfd; struct dirent *dp; if (debug) printf ("putfiles (%s, %d, %s level: %d)\n", dir, out, path,*level); /* Put the directory file itself to the output as a file. */ fgfileout (dir, out, LF_DIR, path, *level); if ((dfd = opendir (dir)) == NULL) { fflush (stdout); fprintf (stderr, "cannot open subdirectory `%s%s'\n", path, dir); fflush (stderr); return (0); } getcwd (oldpath, SZ_PATHNAME); sprintf (newpath, "%s%s", dname(path), dir); strcpy (newpath, dname(newpath)); if (debug) printf ("change directory to %s\n", newpath); if (chdir (dir) == ERR) { closedir (dfd); fflush (stdout); fprintf (stderr, "cannot change directory to `%s'\n", newpath); fflush (stderr); return (0); } /* Put each file in the directory to the output file. Recursively * read any directories encountered. */ dirl = *level + 1; while ((dp = readdir(dfd)) != NULL) { if (strcmp (dp->d_name, ".") == 0 || strcmp (dp->d_name, "..") == 0) continue; /* skip self and parent */ if ((ftype = filetype (dp->d_name)) == LF_DIR) { putfiles (dp->d_name, out, newpath, &dirl); } else fgfileout (dp->d_name, out, ftype, newpath, dirl); } if (debug) printf ("return from subdirectory %s\n", newpath); if (chdir (oldpath) == ERR) { fflush (stdout); fprintf (stderr, "cannot return from subdirectory `%s'\n", newpath); fflush (stderr); } closedir (dfd); } /* FGFILEOUT -- Write the named file to the output in FITS format. */ fgfileout (fname, out, ftype, path, level) char *fname; /* file to be output */ int out; /* output stream */ int ftype; /* file type */ char *path; /* current path */ int level; /* directory level */ { struct stat fst; struct fheader fh; char card[CARDLEN], type[20]; char sval[SLEN]; register struct _modebits *mp; char *tp, *fn, *get_owner(), *get_group(); pointer kwdb; int k, nbh, nbp, usize, in, get_checksum(), hdr_plus; long in_off, out_off; unsigned int datasum; int nkw, i, ep, status, ncards, pcount, hd_nlines, hd_cards; if (debug) printf ("put file `%s', type %d\n", fname, ftype); switch(ftype) { case LF_SYMLINK: if (omitsymlink) return (0); break; case LF_BIN: if (omitbin) return (0); break; case LF_TXT: if (omittxt) return (0); break; case LF_DIR: if (omitdir) return (0); break; case FITS: if (omitfits) return (0); break; case FITS_MEF: if (omitfitsmef) return (0); break; default: return (0); break; } if ((in = open (fname, 0, O_RDONLY)) == ERR) { fflush (stdout); fprintf (stderr, "Warning: cannot open file `%s'\n", fname); fflush (stderr); return (0); } /* Format and output the file header. */ memset (&fh, 0, sizeof(fh)); strcpy (fh.name, path); strcat (fh.name, fname); strcpy (fh.linkname, ""); fh.linkflag = 0; fh.isdir = 0; /* Get info on file to make file header. */ if (fstat (in, &fst) == ERR) { fflush (stdout); fprintf (stderr, "Warning: could not stat file `%s'\n", fname); fflush (stderr); return (0); } fh.uid = fst.st_uid; fh.gid = fst.st_gid; fh.mode = fst.st_mode; fh.ctime = fst.st_ctime; fh.mtime = fst.st_mtime; fh.size = fst.st_size; strcpy (sval, fname); if (ftype == LF_SYMLINK) { struct stat fi; int n; lstat (fname, &fi); /* Set attributes of symbolic link, not file pointed to. */ fh.uid = fi.st_uid; fh.gid = fi.st_gid; fh.mode = fi.st_mode; fh.ctime = fi.st_ctime; fh.mtime = fi.st_mtime; fh.size = 0; fh.linkflag = LF_SYMLINK; if ((n = readlink (fname, fh.linkname, NAMSIZ)) > 0) fh.linkname[n] = '\0'; sprintf(sval, "%s -> %s",fname,fh.linkname); } /* Open keyword database */ if (!(kwdb = kwdb_Open ("EHU"))) { fflush (stdout); fprintf (stderr, "Warning: Could not open EHU kwdb `%s'\n", fname); fflush (stderr); return (0); } hdr_plus = 0; if (fh.linkflag == LF_SYMLINK) { tp = sval; fn = fname; } else { if (strcmp (fname, ".") == 0) tp = group; else tp = gname(sval); fn = tp; } if (ftype == FITS || ftype == FITS_MEF) { if ((ncards = kwdb_ReadFITS (kwdb, in, MAXENTRIES, NULL)) < 0) { fflush (stdout); fprintf (stderr, "cannot read FITS header `%s'\n", fname); fflush (stderr); } /* If file is empty, treat as text */ if (ncards == 0) { ftype = LF_TXT; goto emptyfile; } ep = kwdb_Lookup (kwdb, "SIMPLE", 0); kwdb_RenameEntry (kwdb, ep, "XTENSION"); kwdb_SetValue (kwdb, "XTENSION", "IMAGE"); nkw = kwdb_Len (kwdb); hd_nlines = nkw; nbp = pix_block(kwdb); if (toc) /* Input file usize */ usize = ((nkw+35)/36)*36*80 + nbp*FBLOCK; if (sums == YES) { /* Check if the PHU has these keywords 1st */ if (kwdb_Lookup (kwdb, "CHECKSUM", 0) == 0) { kwdb_AddEntry (kwdb, "CHECKSUM", "0000000000000000", "S", "ASCII 1's complement checksum"); hd_nlines++; } else /* Reset the value */ kwdb_SetValue (kwdb, "CHECKSUM", "0000000000000000"); if (kwdb_Lookup (kwdb, "DATASUM", 0) == 0) { kwdb_AddEntry (kwdb, "DATASUM", " 0", "S", "checksum of data records"); hd_nlines++; } else kwdb_SetValue (kwdb, "DATASUM", " 0"); if (kwdb_Lookup (kwdb, "CHECKVER", 0) == 0) { kwdb_AddEntry (kwdb, "CHECKVER", "COMPLEMENT", "S", "checksum version ID"); hd_nlines++; } else kwdb_SetValue (kwdb, "CHECKVER", "COMPLEMENT"); } /* Advance input file pointer to the end of the current FBLOCK * mark. kwdb_ReadFITS only read as much as ncards. */ in_off = lseek (in, 0, SEEK_CUR); in_off = ((in_off + 2879)/2880)*2880; in_off = lseek (in, in_off, SEEK_SET); /* In case we need to strech the PHU to accomodate the FG * keywords set one extra FBLOCK. */ k = (36-nkw) % 36; if (k > 0 && k < 10) hdr_plus = 2880; } else { emptyfile: kwdb_AddEntry (kwdb, "XTENSION","FOREIGN", "S", "NOAO xtension type"); kwdb_AddEntry (kwdb, "BITPIX","8", "N", "Bits per pixel (byte)"); kwdb_AddEntry (kwdb, "NAXIS", "0", "N", "No Image matrix"); kwdb_AddEntry (kwdb, "GCOUNT", "1", "N", "One group"); pcount = fh.size; if (ftype == LF_DIR || ftype == LF_SYMLINK) pcount = 0; kwdb_AddEntry (kwdb, "PCOUNT", str(pcount), "N", "File size in bytes"); kwdb_AddEntry (kwdb, "EXTNAME", fn, "S", "Filename"); kwdb_AddEntry (kwdb, "EXTVER","1", "N", ""); kwdb_AddEntry (kwdb, "EXTLEVEL", str(level), "N","Directory level"); hd_nlines = 8; if (sums == YES) { kwdb_AddEntry (kwdb, "CHECKSUM", "0000000000000000", "S", "ASCII 1's complement checksum"); kwdb_AddEntry (kwdb, "DATASUM", " 0", "S", "checksum of data records"); kwdb_AddEntry (kwdb, "CHECKVER", "COMPLEMENT", "S", "checksum version ID"); hd_nlines = 11; } } kwdb_AddEntry (kwdb, "FG_GROUP", group, "S", "Group Name"); kwdb_AddEntry (kwdb, "FG_FNAME", tp, "S", "Filename"); switch(ftype) { case LF_SYMLINK: strcpy (type, "symlink"); break; case LF_BIN: strcpy (type, "binary"); break; case LF_TXT: strcpy (type, "text"); break; case LF_DIR: strcpy (type, "directory"); break; case FITS: strcpy (type, "FITS"); break; case FITS_MEF: strcpy (type, "FITS-MEF"); break; default: strcpy (type, "other"); break; } kwdb_AddEntry (kwdb, "FG_FTYPE", type, "S", "File type"); kwdb_AddEntry (kwdb, "FG_LEVEL", str(level), "N", "Directory level"); pcount = fh.size + hdr_plus; if (ftype == LF_DIR || ftype == LF_SYMLINK) pcount = 0; kwdb_AddEntry (kwdb, "FG_FSIZE", str(pcount), "N", "Data size (bytes)"); tp = sval; *tp = '-'; if (ftype == LF_DIR) *tp++ = 'd'; else if (ftype == LF_SYMLINK) *tp++ = 'l'; else tp++; for (mp=modebits; mp->code; mp++) *tp++ = mp->code & fh.mode ? mp->ch : '-'; *tp=0; kwdb_AddEntry (kwdb, "FG_FMODE", sval, "S", "File mode"); kwdb_AddEntry (kwdb, "FG_FUOWN", get_owner(fh.uid), "S", "File UID"); kwdb_AddEntry (kwdb, "FG_FUGRP", get_group(fh.gid), "S", "File GID"); { struct tm *tm; tm = gmtime(&fh.ctime); sprintf(card,"%d-%2.2d-%2.2dT%2.2d:%2.2d:%2.2d",tm->tm_year+1900, tm->tm_mon+1,tm->tm_mday,tm->tm_hour,tm->tm_min,tm->tm_sec); kwdb_AddEntry (kwdb, "FG_CTIME", card, "S", "file ctime (GMT)"); tm = gmtime(&fh.mtime); sprintf(card,"%d-%2.2d-%2.2dT%2.2d:%2.2d:%2.2d",tm->tm_year+1900, tm->tm_mon+1,tm->tm_mday,tm->tm_hour,tm->tm_min,tm->tm_sec); kwdb_AddEntry (kwdb, "FG_MTIME", card, "S", "file mtime (GMT)"); } hd_cards = hd_nlines + 10 + 1; if (toc == NO) { /* Get the current output file position */ out_off = lseek (out, 0, SEEK_CUR); ncards = kwdb_WriteFITS (kwdb, out); nbh = (ncards + 1 + 35)/36; /* Fblocks of header */ ncards = ncards % 36; /* Blank fill the remainder of the header area. */ memset (card, ' ', CARDLEN); for (i = ncards + 1; i < 36; i++) write (out, card, CARDLEN); /* Write the END card to mark the end of the header. */ strcpy (card, "END"); memset (card+3, ' ', CARDLEN-3); write (out, card, CARDLEN); } kwdb_Close (kwdb); if (ftype == LF_DIR) { strcpy (fh.name, dname(fh.name)); fh.size = 0; fh.isdir = 1; fh.linkflag = LF_DIR; } /* Copy the file data. */ if ((toc==NO) && fh.size > 0 && !fh.isdir && !fh.linkflag) copyfile (in, &fh, out, ftype, out_off, nbp, &datasum); if (verbose && !toc) { printheader (stdout, &fh, type); fflush (stdout); } /* Generate one liner for TOC */ if (toc) toc_card (in, &fh, ftype, hd_cards, level, usize); /* Calculate the checksum now */ if (sums == YES) if ((toc==NO) && fh.size > 0 && !fh.isdir && !fh.linkflag) get_checksum(out, out_off, nbh, &datasum); close (in); } /* GET_OWNER -- Obtain user name for the password file given the uid. */ char * get_owner(fuid) int fuid; { /* Get owner name. Once the owner name string has been retrieved * for a particular (system wide unique) UID, cache it, to speed * up multiple requests for the same UID. */ static int uid = 0; static char owner[SZ_OWNERSTR+1]; struct passwd *pw; if (fuid == uid) return(owner); else { /* setpwent(); */ pw = getpwuid (fuid); /* endpwent(); */ if (pw == NULL) strcpy(owner, ""); else { strncpy (owner, pw->pw_name, SZ_OWNERSTR); uid = fuid; } } owner[SZ_OWNERSTR] = 0; return(owner); } /* GET_GROUP -- Obtain group name for the file given the uid. */ char * get_group(fuid) int fuid; { /* Get owner name. Once the owner name string has been retrieved * for a particular (system wide unique) UID, cache it, to speed * up multiple requests for the same UID. */ static int gid = 0; static char owner[SZ_OWNERSTR+1]; struct group *gp; if (fuid == gid) return(owner); else { /* setpwent(); */ gp = getgrgid (fuid); /* endpwent(); */ if (gp == NULL) strcpy(owner, ""); else { strncpy (owner, gp->gr_name, SZ_OWNERSTR); gid = fuid; } } owner[SZ_OWNERSTR] = 0; return(owner); } /* CHECKSUM -- Calculate the checksum for a FITS extension unit, including * header and data. */ get_checksum (fd, out_offset, nbh, datasum) int fd; /* file descriptor */ long out_offset; /* offset of the beginning of FITS header */ int nbh; /* number of FBLOCK of header */ unsigned int *datasum; /* datasum value */ { unsigned short sum16; unsigned int sum32; char record[FBLOCK*NBLOCK]; char ascii[161]; unsigned int add_1s_comp(); int i, bks, ncards, ep, pos, recsize, permute; pointer kwdb; sum16 = 0; sum32 = 0; permute = 1; /* Position the output file at the beginning of the EHDU to start * reading data. Read blocks of FBLOCK*NBLOCK bytes, then read a last * partial block FBLOCK*nb bytes. */ pos = lseek (fd, out_offset, SEEK_SET); bks = nbh/NBLOCK; for (i=1; i<=bks; i++) { recsize = read (fd, record, FBLOCK*NBLOCK); checksum (record, recsize, &sum16, &sum32); } if (nbh % NBLOCK != 0) { recsize = read (fd, record, (nbh % 10)*FBLOCK); checksum (record, recsize, &sum16, &sum32); } /* Now add datasum and checksum and put the result in * 1's complement with permute in a string. */ char_encode (~add_1s_comp(*datasum,sum32), ascii, 4, permute); /* Position the output file at the beginning of the EHDU to * read FITS header */ pos = lseek (fd, out_offset, SEEK_SET); kwdb = kwdb_Open ("PHU"); if ((ncards = kwdb_ReadFITS (kwdb, fd, MAXENTRIES, NULL)) < 0) { fflush (stdout); fprintf (stderr, "cannot read FITS header in checksum"); fflush (stderr); } kwdb_SetValue (kwdb, "CHECKSUM", ascii); /* Position the output file at the beginning of the EHDU to * write back the update FITS header */ pos = lseek (fd, out_offset, SEEK_SET); ncards = kwdb_WriteFITS (kwdb, out); kwdb_Close(kwdb); /* put file pointer to the EOF position */ pos = lseek (fd, 0, SEEK_END); } /* CHECKSUM -- Increment the checksum of a character array. The * calling routine must zero the checksum initially. Shorts are * assumed to be 16 bits, ints 32 bits. */ /* Explicitly exclude those ASCII characters that fall between the * upper and lower case alphanumerics (<=>?@[\]^_`) from the encoding. * Which is to say that only the digits 0-9, letters A-Z, and letters * a-r should appear in the ASCII coding for the unsigned integers. */ #define NX 13 unsigned exclude[NX] = { 0x3a, 0x3b, 0x3c, 0x3d, 0x3e, 0x3f, 0x40, 0x5b, 0x5c, 0x5d, 0x5e, 0x5f, 0x60 }; int offset = 0x30; /* ASCII 0 (zero) character */ /* Internet checksum algorithm, 16/32 bit unsigned integer version: */ checksum (buf, length, sum16, sum32) char *buf; int length; unsigned short *sum16; unsigned int *sum32; { unsigned short *sbuf; int len, remain, i; unsigned int hi, lo, hicarry, locarry, tmp16; sbuf = (unsigned short *) buf; len = 2*(length / 4); /* make sure len is even */ remain = length % 4; /* add remaining bytes below */ /* Extract the hi and lo words - the 1's complement checksum * is associative and commutative, so it can be accumulated in * any order subject to integer and short integer alignment. * By separating the odd and even short words explicitly, both * the 32 bit and 16 bit checksums are calculated (although the * latter follows directly from the former in any case) and more * importantly, the carry bits can be accumulated efficiently * (subject to short integer overflow - the buffer length should * be restricted to less than 2**17 = 131072). */ hi = (*sum32 >> 16); lo = (*sum32 << 16) >> 16; for (i=0; i < len; i+=2) { hi += sbuf[i]; lo += sbuf[i+1]; } /* any remaining bytes are zero filled on the right */ if (remain) { if (remain >= 1) hi += buf[2*len] * 0x100; if (remain >= 2) hi += buf[2*len+1]; if (remain == 3) lo += buf[2*len+2] * 0x100; } /* fold the carried bits back into the hi and lo words */ hicarry = hi >> 16; locarry = lo >> 16; while (hicarry || locarry) { hi = (hi & 0xFFFF) + locarry; lo = (lo & 0xFFFF) + hicarry; hicarry = hi >> 16; locarry = lo >> 16; } /* simply add the odd and even checksums (with carry) to get the * 16 bit checksum, mask the two to reconstruct the 32 bit sum */ tmp16 = hi + lo; while (tmp16 >> 16) tmp16 = (tmp16 & 0xFFFF) + (tmp16 >> 16); *sum16 = tmp16; *sum32 = (hi << 16) + lo; } /* CHAR_ENCODE -- Encode an unsigned integer into a printable ASCII * string. The input bytes are each represented by four output bytes * whose sum is equal to the input integer, offset by 0x30 per byte. * The output is restricted to alphanumerics. * * This is intended to be used to embed the complement of a file checksum * within an (originally 0'ed) ASCII field in the file. The resulting * file checksum will then be the 1's complement -0 value (all 1's). * This is an additive identity value among other nifty properties. The * embedded ASCII field must be 16 or 32 bit aligned, or the characters * can be permuted to compensate. * * To invert the encoding, simply subtract the offset from each byte * and pass the resulting string to checksum. */ char_encode (value, ascii, nbytes, permute) unsigned int value; char *ascii; /* at least 17 characters long */ int nbytes; int permute; { int byte, quotient, remainder, ch[4], check, i, j, k; char asc[32]; for (i=0; i < nbytes; i++) { byte = (value << 8*(i+4-nbytes)) >> 24; /* Divide each byte into 4 that are constrained to be printable * ASCII characters. The four bytes will have the same initial * value (except for the remainder from the division), but will be * shifted higher and lower by pairs to avoid special characters. */ quotient = byte / 4 + offset; remainder = byte % 4; for (j=0; j < 4; j++) ch[j] = quotient; /* could divide this between the bytes, but the 3 character * slack happens to fit within the ascii alphanumeric range */ ch[0] += remainder; /* Any run of adjoining ASCII characters to exclude must be * shorter (including the remainder) than the runs of regular * characters on either side. */ check = 1; while (check) for (check=0, k=0; k < NX; k++) for (j=0; j < 4; j+=2) if (ch[j]==exclude[k] || ch[j+1]==exclude[k]) { ch[j]++; ch[j+1]--; check++; } /* ascii[j*nbytes+(i+permute)%nbytes] = ch[j]; */ for (j=0; j < 4; j++) asc[j*nbytes+i] = ch[j]; } for (i=0; i < 4*nbytes; i++) ascii[i] = asc[(i+4*nbytes-permute)%(4*nbytes)]; ascii[4*nbytes] = 0; } /* ADD_1S_COMP -- add two unsigned integer values using 1's complement * addition (wrap the overflow back into the low order bits). Could do * the same thing using checksum(), but this is a little more obvious. * To subtract, just complement (~) one of the arguments. */ unsigned int add_1s_comp (u1, u2) unsigned int u1, u2; { unsigned int hi, lo, hicarry, locarry; hi = (u1 >> 16) + (u2 >> 16); lo = ((u1 << 16) >> 16) + ((u2 << 16) >> 16); hicarry = hi >> 16; locarry = lo >> 16; while (hicarry || locarry) { hi = (hi & 0xFFFF) + locarry; lo = (lo & 0xFFFF) + hicarry; hicarry = hi >> 16; locarry = lo >> 16; } return ((hi << 16) + lo); } /* PRINTHEADER -- Print one line of information per file. * */ printheader (fp, fh, type) FILE *fp; /* output file */ register struct fheader *fh; /* file header struct */ char *type; /* type of file */ { register struct _modebits *mp; char c, *tp, line[CARDLEN]; int k; long clk; clk = fh->mtime; tp = ctime (&fh->mtime); fprintf (fp, "%-4d %-10.10s %9d %-12.12s %-4.4s %s", ++count,type, fh->size, tp + 4, tp + 20, fh->name); if (fh->linkflag && *fh->linkname) { fprintf (fp, " -> %s ", fh->linkname); } fprintf(fp, "\n"); } /* COPYFILE -- Copy bytes from the input file to the output file. Each file * consists of a integral number of FBLOCK size blocks on the output file. */ copyfile (in, fh, out, ftype, out_off, nbp, datasum) int in; /* input file descriptor */ struct fheader *fh; /* file header structure */ int out; /* output file descriptor */ int ftype; /* file type LF_TXT and others */ int out_off; /* points to the beginning of EHU */ int nbp; /* number of Fblocks in data unit */ unsigned int *datasum; /* output datasum value */ { register int i; int nbytes, ncards, pos; int npad, nb, bks; char buf[FBLOCK*10], ascii[161]; int ipos, epos, in_off; unsigned short sum16; unsigned int sum32; pointer kwdb; sum16 = 0; sum32 = 0; nb = 0; /* If we are reading a MEF file, compute the checksum for * the PDU only */ if (ftype == FITS_MEF) { bks = nbp/10; for (i=1; i<=bks; i++) { nbytes = read (in, buf, FBLOCK*10); write (out, buf, nbytes); if (sums == YES) checksum (buf, nbytes, &sum16, &sum32); nb = nb + nbytes; } if (nbp % 10 != 0) { nbytes = read (in, buf, (nbp % 10)*FBLOCK); write (out, buf, nbytes); if (sums == YES) checksum (buf, nbytes, &sum16, &sum32); nb = nb + nbytes; } } /* Now read and write */ ipos = lseek(out, 0, SEEK_CUR); while ((nbytes = read (in, buf, FBLOCK*10)) != 0) { write (out, buf, nbytes); if (ftype != FITS_MEF) { if (sums == YES) checksum (buf, nbytes, &sum16, &sum32); nb = nb + nbytes; } } /* Pad data unit with blanks for text data and zero for * other datatype */ npad = 2880 - nb % 2880; i = 0; if (ftype == LF_TXT) i = ' '; if ((npad % 2880) > 0) { memset (buf, i, npad); if (sums == YES) checksum (buf, npad, &sum16, &sum32); write (out, buf, npad); } /* The checksum algorithm does not work for small text files * that are not multiple or 4 bytes. Recalculate it for the * output data extension since this one is multiple of 2880. */ if (sums == YES) { if (ftype == LF_TXT) { epos = lseek(out, 0, SEEK_CUR); sum16=0; sum32=0; bks = (epos-ipos)/(FBLOCK*10); in_off = lseek(out, ipos, SEEK_SET); for (i=1; i<=bks; i++) { nbytes = read (out, buf, FBLOCK*10); checksum (buf, nbytes, &sum16, &sum32); } nbp = (epos-ipos) % (FBLOCK*10); if (nbp != 0) { nbytes = read (out, buf, nbp); checksum (buf, nbytes, &sum16, &sum32); } } *datasum = sum32; /* go to the start of EHU */ pos = lseek (out, out_off, SEEK_SET); kwdb = kwdb_Open ("PHU"); if ((ncards = kwdb_ReadFITS (kwdb, out, MAXENTRIES, NULL)) < 0) { fflush (stdout); fprintf (stderr, "cannot read FITS header in copyfile"); fflush (stderr); } if (sums == YES) { /* update DATASUM value */ sprintf(ascii,"%-10lu",sum32); kwdb_SetValue (kwdb, "DATASUM", ascii); } /* Position the output file at the beginning of the EHDU to * write back the update FITS header */ pos = lseek (out, out_off, SEEK_SET); ncards = kwdb_WriteFITS (kwdb, out); kwdb_Close(kwdb); } } /* DNAME -- Normalize a directory pathname. For unix, this means convert * an // sequences into a single /, and make sure the directory pathname ends * in a single /. */ char * dname (dir) char *dir; { register char *ip, *op; static char path[SZ_PATHNAME+1]; for (ip=dir, op=path; *ip; *op++ = *ip++) while (*ip == '/' && *(ip+1) == '/') ip++; if (op > path && *(op-1) != '/') *op++ = '/'; *op = (char )NULL; return (path); } /* * FILETYPE -- Determine whether the named file is a text file, a binary * file, or a directory. */ char *binextn[] = { /* Known binary file extensions */ ".o", ".e", ".a", ".mip", ".pl", ".gif", ".jpeg", ".jpg", ".tiff", ".tif", ".gz", NULL }; char *srcextn[] = { /* Known source file extensions */ ".x", ".h", ".f", ".c", ".s", ".hlp", NULL }; char *fitsextn[] = { /* Known FITS file extensions */ ".fits", ".fit", NULL }; #define SZ_TESTBLOCK 1024 /* for TEXT/BINARY heuristic */ #define MAX_LINELEN 256 /* when looking for newlines */ #define R 04 /* UNIX access() codes */ #define W 02 #define ctrlcode(c) ((c) >= '\007' && (c) <= '\017') /* FILETYPE -- Determine the type of a file. If the file has one of the * known source file extensions we assume it is a text file; if it has a well * known binary file extension we assume it is a binary file; otherwise we call * os_access to determine the file type. */ filetype (fname) char *fname; /* name of file to be examined */ { register char *ip, *ep; register int n, ch, i; int fd, nchars, newline_seen; char *extn, buf[SZ_TESTBLOCK]; int fits_mef(); struct stat fi; if (lstat(fname, &fi) == 0) { if ((fi.st_mode & S_IFMT) == S_IFDIR) return(LF_DIR); else if ((fi.st_mode & S_IFMT) == S_IFLNK) return(LF_SYMLINK); } /* Get filename extension. */ extn = NULL; for (ip=fname; (ch = *ip); ip++) if (ch == '.') extn = ip; /* If the filename has a extension, check the list of known text and * binary file extensions to see if we can make a quick determination * of the file type. */ if (extn) { ch = *(extn + 1); /* Known source file extension? */ for (i=0; (ep = srcextn[i]); i++) if (*(ep+1) == ch) if (strcmp (ep, extn) == 0) return (LF_TXT); /* Known binary file extension? */ for (i=0; (ep = binextn[i]); i++) if (*(ep+1) == ch) if (strcmp (ep, extn) == 0) return (LF_BIN); /* Known FITS file extension? */ for (i=0; (ep = fitsextn[i]); i++) if (*(ep+1) == ch) if (strcmp (ep, extn) == 0) return (fits_mef(fname, fi.st_size)); } /* Do NOT read from a special device (may block) */ if ((fi.st_mode & S_IFMT) & S_IFREG) { /* If we are testing for a text file the portion of the file * tested must consist of only printable ascii characters or * whitespace, with occasional newline line delimiters. * Control characters embedded in the text will cause the * heuristic to fail. We require newlines to be present in * the text to disinguish the case of a binary file containing * only ascii data, e.g., a cardimage file. */ fd = open ((char *)fname, 0); if (fd >= 0) { nchars = read (fd, buf, SZ_TESTBLOCK); if (nchars == 0) /* Check for empty file */ return(LF_BIN); ip = buf; for (n=nchars, newline_seen=0; --n >= 0; ) { ch = *ip++; if (ch == '\n') newline_seen++; else if (!isprint(ch) && !isspace(ch) && !ctrlcode(ch)) break; } close (fd); if (n >= 0 || (nchars > MAX_LINELEN && !newline_seen)) return(LF_BIN); else return(LF_TXT); } } return (OTHER); } /* FITS_MEF -- Determines by reading the FITS file if is FITS (single unit) * or a FITS-MEF (multiple units). */ fits_mef(fname, filesize) char *fname; int filesize; /* fname size */ { int ncards; int fd, datasize, size; char *sval; pointer kwdb; if ((fd = open (fname, 0)) <= 0) {; fflush (stdout); fprintf (stderr, "cannot open FITS file `%s'\n", fname); fflush (stderr); return (0); } kwdb = kwdb_Open ("FITS"); if ((ncards = kwdb_ReadFITS (kwdb, fd, MAXENTRIES, NULL)) < 0) { fflush (stdout); fprintf (stderr, "cannot read FITS header `%s'\n", fname); fflush (stderr); return (0); } close (fd); datasize = pix_block (kwdb); size = datasize * FBLOCK + (ncards+1) * CARDLEN; kwdb_Close (kwdb); if (filesize > size) return (FITS_MEF); else return (FITS); } static char * str (n) int n; { static char s[32]; sprintf (s, "%d", n); return (s); } /* GNAME -- Return a filename with no pre or post '/' if it * has any. */ char *gname(name) char *name; { char *ip; ip = rindex(name,'/'); if (ip != NULL && *(ip+1) == (char )NULL) *ip = (char )'\0'; ip = rindex(name,'/'); if(ip == NULL) return(name); else return(ip+1); } /* TOC_CARD -- Format a Table of content card of the form: * * Count HDR_OFF FSIZE FTYPE FLEVEL FNAME * * e.g. 1 1 0 fd 1 . 2 2 4 ff 2 h36.fits 3 6 0 fd 2 nza * * Count: Extension counter * HDR_OFF: Extension header offset in 2880 bytes block units * FSIZE: Extension unit size in 2880 bytes block units * FTYPE: Type of FITS extension: fd: directory fb: binary file ft: text file fs: symbolic link ff: FITS file fm: FITS_MEF file * FLEVEL: Directory level of the unit. 1 is top directory * FNAME: File name for the extension unit */ toc_card (in, fh, ftype, hd_cards, level, usize) register struct fheader *fh; /* file header struct */ int ftype; /* type of file */ int hd_cards; int level; /* Directory level */ int usize; /* FITS unit size */ { char type[3], *tp, line[CARDLEN]; int c, k, fsize; switch(ftype) { case LF_SYMLINK: strcpy (type, "fl"); break; case LF_BIN: strcpy (type, "fb"); break; case LF_TXT: strcpy (type, "ft"); break; case LF_DIR: strcpy (type, "fd"); break; case FITS: strcpy (type, "ff"); break ; case FITS_MEF: strcpy (type, "fm"); break; default: strcpy (type, "??"); break; } fsize = (fh->size+2879)/2880; c = level <= 9 ? level+'0' : level-10+'a'; sprintf (slines, " %-4d %4d %4d %s %c %s", ++count, hdr_off/2880, fsize, type, c, gname(fh->name)); slines = slines + TOCLEN; if (count >= maxcount) { maxcount += MAX_TOC; slines= (char *)realloc (maxcount, TOCLEN); } if (ftype == FITS_MEF || ftype == FITS) { /* the MEF PHU can run of header space and go to next block on * output. Account the offset for this effect */ k = hd_cards % 36; if (k > 0 && k < 10) hdr_off = hdr_off + 2880; } if (ftype == FITS_MEF) { list_mef(in, usize); } else if (ftype == FITS) hdr_off = hdr_off + usize; else hdr_off = hdr_off + fsize*2880 + ((hd_cards + 35)/36)*36*80; } /* LIST_TOC -- List and update if necessary the header offset * column because we have gone over one or more FITS blocks with lines of TOC. */ list_toc (kwdb) pointer kwdb; /* Output db */ { char *s, line[CARDLEN]; int i, k, hoff, nb; kwdb_AddEntry(kwdb, "TOCLEN", str(count), "N", "Number of entries in TOC"); kwdb_AddEntry(kwdb, "COMMENT", "Col 11-14: Index","C",""); kwdb_AddEntry(kwdb, "COMMENT", "Col 16-19: Header Offset (FITS block)", "C",""); kwdb_AddEntry(kwdb, "COMMENT", "Col 21-24: File size (FITS block)", "C",""); kwdb_AddEntry(kwdb, "COMMENT", "Col 26-27: FITS type: f(tbdlfm) or (tbio)","C",""); kwdb_AddEntry(kwdb, "COMMENT", "Col 29: Directory Level","C",""); kwdb_AddEntry(kwdb, "COMMENT", "Col 31-80: Filename ","C",""); kwdb_AddEntry(kwdb, "", "","T",""); nb = count/36; /* number of blocks to add */ if (count % 36 > 21) nb++; /* add one more if necessary */ if (nb == 0) { for (s=slines-TOCLEN*count, k=count; k > 0; s+=TOCLEN,k--) { kwdb_AddEntry (kwdb, " ", s, "T",""); if (verbose) printf("%s\n",s); } } else { for (s=slines-TOCLEN*count, k=count; k > 0; s+=TOCLEN,k--) { sscanf (s, "%d %d", &i, &hoff); hoff = hoff + nb; sprintf (line, " %-4d %4d%s", i, hoff, s+11); kwdb_AddEntry (kwdb, " ", line, "T",""); if (verbose) printf("%s\n",line); } } } /* LIST_MEF -- Lists the extension units of a mef file when TOC is * requested. */ list_mef(fd, usize) int fd; /* input fd */ int usize; /* size of MEF PHDU */ { int ncards, bytepix, pcount, naxes, i, npix; int stat, foff, datasize; char ft, *sval; pointer kwdb; /* At this point we have read the header; we need to position * at the beginning of the next EHU. */ foff = lseek (fd, usize, SEEK_SET); /* Point to the beginning of the 1st EHU */ while(1) { kwdb = kwdb_Open ("FITS"); ncards = kwdb_ReadFITS (kwdb, fd, MAXENTRIES, NULL); if (ncards < 0) { fflush (stdout); fprintf (stderr, "cannot read FITS header in list_mef()"); fflush (stderr); return (0); } else if (ncards == 0) { hdr_off = hdr_off + foff; kwdb_Close (kwdb); return (0); } sval = kwdb_GetValue (kwdb,"XTENSION"); if (sval != NULL) { if ( !strcmp(sval, "IMAGE ")) ft = 'i'; else if (!strcmp(sval, "TABLE ")) ft = 't'; else if (!strcmp(sval, "BINTABLE")) ft = 'b'; else if (!strcmp(sval, "FOREIGN ")) ft = 'f'; else ft = 'o'; } datasize = pix_block (kwdb); ncards = ((ncards + 35)/36)*36; sprintf(slines," %-4d %4d %7.7c",++count, (hdr_off+foff)/2880, ft); foff = foff + datasize * FBLOCK + ncards * CARDLEN; if (count >= maxcount) { maxcount += MAX_TOC; slines= (char *)realloc (maxcount, TOCLEN); } slines = slines + TOCLEN; stat = lseek (fd, foff, SEEK_SET); if (stat < 0) { kwdb_Close (kwdb); return (0); } } } /* PIX_BLOCK -- Calculate the size of the pixel area for a FITS UNIT * in blocks of 2880. */ pix_block (kwdb) pointer kwdb; { char *sval, *spcount, kwname[8]; int bytepix, naxes, npix, i, pcount; int size; if ((sval = kwdb_GetValue (kwdb, "BITPIX")) == NULL) return(0); bytepix = abs(atoi(sval)) / BYTELEN; naxes = atoi(kwdb_GetValue (kwdb, "NAXIS")); npix = naxes ? 1 : 0; for (i=1; i <= naxes; i++) { sprintf(kwname,"NAXIS%d",i); npix *= atoi(kwdb_GetValue (kwdb, kwname)); } spcount = kwdb_GetValue (kwdb, "PCOUNT"); if (spcount == NULL) pcount = 0; else pcount = atoi(spcount); size = (((npix+pcount) * bytepix) + FBLOCK-1) / FBLOCK; return(size); } fitsutil-2018.07.06/src/fgwrite.cl000066400000000000000000000024221332007674300165450ustar00rootroot00000000000000#{ FGWRITE - Procedure to start the foreign task fgwrite. procedure fgwrite (input, output) string input {prompt="Input FITS files"} string output {prompt="Output MEF file"} bool verbose=yes {prompt="verbose"} string group="" {prompt="FG_GROUP name"} string types="" {prompt="Select filetypes (tbdsfm)"} string exclude="" {prompt="Exclude filetypes (tbdsfm)"} bool phu=yes {prompt="Creates output PHU"} bool checksum=no {prompt="Checksums?"} bool toc=no {prompt="write Table Of Content"} begin string out, inf string in="" string sel="" string excl="" string flags="" string groupn inf = input # Look if the input is a list of files. i = 1 j = stridx (",", inf) if (j == 0) in = inf while (j > 0) { in = in//" "// substr(inf,i,j-1) inf = substr (inf, j+1,input.p_len) j = stridx (",",inf) if (j == 0) in = in//" "// substr(inf,i,j-1) } out = "-f "//output if (verbose == yes) flags = flags//"v" if (toc == yes) flags = flags//"i" if (phu == no) flags = flags//"h" if (checksum == yes) flags = flags//"s" if (flags != "") flags = "-"//flags if (types != "") sel = "-t "//types if (exclude != "") excl = "-o "//exclude t_fgwrite (flags, sel, excl, out, in) end fitsutil-2018.07.06/src/fpack.cl000066400000000000000000000076341332007674300161740ustar00rootroot00000000000000#{ FPACK - Wrapper script for the CFITSIO 'fpack' task procedure fpack (images) string images {prompt="input images"} bool keep = no {prompt="keep input images?"} bool listonly = no {prompt="only list file contents?"} bool verbose = yes {prompt="verbose messages?"} int quantization = 16 {prompt="q level for floating point scaling"} string flags = "" {prompt="explicit CFITSIO flags"} int nimages {prompt="number of images compressed"} bool goahead = no {prompt="continue?"} string *imlist begin string limages, img, outimg, tmpfile, lflags, date1, date2, junk real tstart, tend, hours, seconds, R int count, filsiz, insize, outsize, len, dsize, benefit bool lgo struct tbuf cache sections limages = images if (listonly) { lflags = "-L " # will be concatenated, so needs final blank if (verbose) printf ("list contents, no files created or deleted\n") } else if (strlen (flags) > 1 && stridx ('-', flags) > 0) { lflags = flags // " " if (keep) { printf ("warning: flags may override keep=yes, ") goahead.p_mode="ql"; lgo=goahead; goahead.p_mode="h" if (!lgo) return } } else { lflags = "-q " // quantization // " " if (!keep) lflags += "-D " if (verbose) lflags += "-v " } tmpfile = mktemp ("tmp$fpack_") sections (limages, opt="fullname", > tmpfile) if (sections.nimages <= 0) { printf ("no images in input list\n") return } insize = 0 imlist = tmpfile while (fscan (imlist, img) != EOF) { # preflight check if (! access (img)) { printf ("input image %s not found\n", img) return } len = strlen (img) if (substr (img, len-2, len) == ".fz") { printf ("input image %s is already tile compressed\n", img) return } if (substr (img, len-3, len) == ".imh" && !keep) { printf ('compressing IRAF ".imh" images requires keep=yes\n') return } if (substr (img, len-2, len) == ".gz") outimg = substr (img, 1, len-3) // ".fz" else if (substr (img, len-3, len) == ".imh") outimg = substr (img, 1, len-4) // "fits.fz" else outimg = img // ".fz" if (access (outimg)) { printf ("output image %s already exists\n", outimg) return } filsiz = 0 directory (img, long+) | scan (junk, junk, filsiz) insize += int ((real (filsiz) / 1024.) + 0.5) } if (verbose) { t_fpack ("-V") time | scan (tbuf); print (tbuf) | scan (junk, tstart, date1) printf ("\n%s\n", tbuf) } count = 0 outsize = 0 imlist = tmpfile while (fscan (imlist, img) != EOF) { t_fpack (lflags // osfn(img)) len = strlen (img) if (substr (img, len-2, len) == ".gz") { outimg = substr (img, 1, len-3) // ".fz" } else if (substr (img, len-3, len) == ".imh") { outimg = substr (img, 1, len-4) // "fits.fz" if (access (img//".fz")) rename (img//".fz", outimg, field="all") } else outimg = img // ".fz" filsiz = 0 directory (outimg, long+) | scan (junk, junk, filsiz) outsize += int ((real (filsiz) / 1024.) + 0.5) count += 1 } imlist = ""; delete (tmpfile, ver-, >& "dev$null") nimages = count if (verbose && count > 0) { time | scan (tbuf); print (tbuf) | scan (junk, tend, date2) printf ("%s\n\n", tbuf) # midnight handling is a kludge, but errors will be few & harmless hours = tend - tstart; if (date2 != date1) hours += 24.0 seconds = hours * 3600.0 / count printf ("%d images, %4.2f seconds each, %h elapsed\n\n", count, seconds, hours) printf (" input: %11.3f MB\n", real (insize) / 1024.) if (! listonly && insize > 0 && outsize > 0) { printf ("output: %11.3f MB\n", real (outsize) / 1024.) R = real (insize) / real (outsize) dsize = insize - outsize benefit = int (100.0 * abs (1.0 - 1/R) + 0.5) printf (" saved: %11.3f MB, %d%%\n\n", real (dsize) / 1024., benefit) printf ("relative R = %4.2f\n\n", R) } } end fitsutil-2018.07.06/src/funpack.cl000066400000000000000000000071271332007674300165340ustar00rootroot00000000000000#{ FUNPACK - Wrapper script for the CFITSIO 'funpack' task procedure funpack (images) string images {prompt="input images"} bool keep = no {prompt="keep input images?"} bool listonly = no {prompt="only list file contents?"} bool verbose = yes {prompt="verbose messages?"} bool gzip = no {prompt="recompress with host gzip?"} # string flags = "" {prompt="explicit CFITSIO flags"} int nimages {prompt="number of images uncompressed"} bool goahead = no {prompt="continue?"} string *imlist begin string limages, img, outimg, tmpfile, lflags, date1, date2, junk real tstart, tend, hours, seconds, R int count, filsiz, insize, outsize, len, dsize, benefit bool lgo struct tbuf cache sections limages = images if (listonly) { lflags = "-L " # will be concatenated, so needs final blank if (verbose) printf ("list contents, no files created or deleted\n") # } else if (strlen (flags) > 1 && stridx ('-', flags) > 0) { # lflags = flags // " " # # if (keep) { # printf ("warning: flags may override keep=yes, ") # goahead.p_mode="ql"; lgo=goahead; goahead.p_mode="h" # if (!lgo) return # } } else { lflags = "" if (verbose) lflags = "-v " if (gzip) lflags += "-Z " if (!keep) lflags += "-D " } tmpfile = mktemp ("tmp$fpack_") sections (limages, opt="fullname", > tmpfile) if (sections.nimages <= 0) { printf ("no images in input list\n") return } insize = 0 imlist = tmpfile while (fscan (imlist, img) != EOF) { # preflight check if (! access (img)) { printf ("input image %s not found\n", img) return } len = strlen (img) if (substr (img, len-2, len) != ".fz") { printf ("input image %s does not have .fz suffix\n", img) return } else { outimg = substr (img, 1, len-3) if (access (outimg)) { printf ("output image %s already exists\n", outimg) return } if (gzip) { outimg += ".gz" if (access (outimg)) { printf ("output image %s already exists\n", outimg) return } } } filsiz = 0 directory (img, long+) | scan (junk, junk, filsiz) insize += int ((real (filsiz) / 1024.) + 0.5) } if (verbose) { t_funpack ("-V") time | scan (tbuf); print (tbuf) | scan (junk, tstart, date1) printf ("\n%s\n", tbuf) } count = 0 outsize = 0 imlist = tmpfile while (fscan (imlist, img) != EOF) { t_funpack (lflags // osfn(img)) len = strlen (img) if (substr (img, len-2, len) == ".fz") outimg = substr (img, 1, len-3) # preflight check guarantees lack of intermediate ".fits" file if (gzip) outimg += ".gz" filsiz = 0 directory (outimg, long+) | scan (junk, junk, filsiz) outsize += int ((real (filsiz) / 1024.) + 0.5) count += 1 } imlist = ""; delete (tmpfile, ver-, >& "dev$null") nimages = count if (verbose && count > 0) { time | scan (tbuf); print (tbuf) | scan (junk, tend, date2) printf ("%s\n\n", tbuf) # midnight handling is a kludge, but errors will be few & harmless hours = tend - tstart; if (date2 != date1) hours += 24.0 seconds = hours * 3600.0 / count printf ("%d images, %4.2f seconds per image, %h elapsed\n\n", count, seconds, hours) printf (" input: %11.3f MB\n", real (insize) / 1024.) if (! listonly && insize > 0 && outsize > 0) { printf ("output: %11.3f MB\n", real (outsize) / 1024.) R = real (insize) / real (outsize) dsize = outsize - insize benefit = int (100.0 * abs (1.0 - 1/R) + 0.5) printf ("expand: %11.3f MB, %d%%\n\n", real (dsize) / 1024., benefit) printf ("relative R = %4.2f\n\n", R) } } end fitsutil-2018.07.06/src/fxconvert.par000066400000000000000000000003261332007674300173010ustar00rootroot00000000000000# cfits parameters input,s,a,,,,Input list output,f,a,,,,Output file groups,s,a,,,,List of extensions new_file,b,h,yes,,,New output file? inherit,b,h,no,,,Turn off inherit? verbose,b,h,yes,,,Verbose mode,s,h,ql,,, fitsutil-2018.07.06/src/fxconvert.x000066400000000000000000000121431332007674300167660ustar00rootroot00000000000000# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include # FXCONVERT -- Convert image(s) # # The input images are given by an image template list. The output # is either a matching list of images or a directory. # The number of input images may be either one or match the number of output # images. Image sections are allowed in the input images and are ignored # in the output images. If the input and output image names are the same # then the copy is performed to a temporary file which then replaces the # input image. procedure t_fxconvert() char imtlist1[SZ_LINE] # Input image list char imtlist2[SZ_LINE] # Output image list bool verbose # Print operations? char image1[SZ_PATHNAME] # Input image name char image2[SZ_PATHNAME] # Output image name char dirname1[SZ_PATHNAME] # Directory name char dirname2[SZ_PATHNAME] # Directory name char dot int list1, list2, root_len int imtopen(), imtgetim(), imtlen() int fnldir(), isdirectory(), strldx() bool clgetb() begin # Get input and output image template lists. call clgstr ("input", imtlist1, SZ_LINE) call clgstr ("output", imtlist2, SZ_LINE) verbose = clgetb ("verbose") # Check if the output string is a directory. dot ='.' if (isdirectory (imtlist2, dirname2, SZ_PATHNAME) > 0) { list1 = imtopen (imtlist1) while (imtgetim (list1, image1, SZ_PATHNAME) != EOF) { # Strip the image section first because fnldir recognizes it # as part of a directory. Place the input image name # without a directory or image section in string dirname1. call get_root (image1, image2, SZ_PATHNAME) root_len = fnldir (image2, dirname1, SZ_PATHNAME) call strcpy (image2[root_len + 1], dirname1, SZ_PATHNAME) call strcpy (dirname2, image2, SZ_PATHNAME) call strcat (dirname1, image2, SZ_PATHNAME) root_len = strldx (dot, image2) if (root_len != 0) image2[root_len] = EOS call fxg_imcopy (image1, image2, verbose) } call imtclose (list1) } else { # Expand the input and output image lists. list1 = imtopen (imtlist1) list2 = imtopen (imtlist2) if (imtlen (list1) != imtlen (list2)) { call imtclose (list1) call imtclose (list2) call error (0, "Number of input and output images not the same") } # Do each set of input/output images. while ((imtgetim (list1, image1, SZ_PATHNAME) != EOF) && (imtgetim (list2, image2, SZ_PATHNAME) != EOF)) { call fxg_imcopy (image1, image2, verbose) } call imtclose (list1) call imtclose (list2) } end # FXG_IMCOPY -- Copy an image. Use sequential routines to permit copying # images of any dimension. Perform pixel i/o in the datatype of the image, # to avoid unnecessary type conversion. procedure fxg_imcopy (image1, image2, verbose) char image1[ARB] # Input image char image2[ARB] # Output image bool verbose # Print the operation int npix, junk pointer buf1, buf2, im1, im2 pointer sp, imtemp, section long v1[IM_MAXDIM], v2[IM_MAXDIM] int imgnls(), imgnll(), imgnlr(), imgnld(), imgnlx() int impnls(), impnll(), impnlr(), impnld(), impnlx() pointer immap() begin call smark (sp) call salloc (imtemp, SZ_PATHNAME, TY_CHAR) call salloc (section, SZ_FNAME, TY_CHAR) # Map the input image. im1 = immap (image1, READ_ONLY, 0) # If the output has a section appended we are writing to a # section of an existing image. Otherwise get a temporary # output image name and map it as a copy of the input image. # Copy the input image to the temporary output image and unmap # the images. Release the temporary image name. call imgsection (image2, Memc[section], SZ_FNAME) if (Memc[section] != EOS) { call strcpy (image2, Memc[imtemp], SZ_PATHNAME) im2 = immap (image2, READ_WRITE, 0) } else { call xt_mkimtemp (image1, image2, Memc[imtemp], SZ_PATHNAME) im2 = immap (image2, NEW_COPY, im1) } # If verbose print the operation. if (verbose) { call printf ("%s -> %s\n") call pargstr (IM_HDRFILE(im1)) call pargstr (IM_HDRFILE(im2)) } # Setup start vector for sequential reads and writes. call amovkl (long(1), v1, IM_MAXDIM) call amovkl (long(1), v2, IM_MAXDIM) # Copy the image. npix = IM_LEN(im1, 1) switch (IM_PIXTYPE(im1)) { case TY_SHORT: while (imgnls (im1, buf1, v1) != EOF) { junk = impnls (im2, buf2, v2) call amovs (Mems[buf1], Mems[buf2], npix) } case TY_USHORT, TY_INT, TY_LONG: while (imgnll (im1, buf1, v1) != EOF) { junk = impnll (im2, buf2, v2) call amovl (Meml[buf1], Meml[buf2], npix) } case TY_REAL: while (imgnlr (im1, buf1, v1) != EOF) { junk = impnlr (im2, buf2, v2) call amovr (Memr[buf1], Memr[buf2], npix) } case TY_DOUBLE: while (imgnld (im1, buf1, v1) != EOF) { junk = impnld (im2, buf2, v2) call amovd (Memd[buf1], Memd[buf2], npix) } case TY_COMPLEX: while (imgnlx (im1, buf1, v1) != EOF) { junk = impnlx (im2, buf2, v2) call amovx (Memx[buf1], Memx[buf2], npix) } default: call error (1, "unknown pixel datatype") } # Unmap the images. call imunmap (im2) call imunmap (im1) call xt_delimtemp (image2, Memc[imtemp]) call sfree(sp) end fitsutil-2018.07.06/src/fxcopy.par000066400000000000000000000002631332007674300165730ustar00rootroot00000000000000# cfits parameters input,s,a,,,,Input list output,f,a,,,,Output file groups,s,a,,,,List of extensions new_file,b,h,yes,,,New output file? verbose,b,h,yes,,,Verbose mode,s,h,ql,,, fitsutil-2018.07.06/src/fxcopy.x000066400000000000000000000074641332007674300162720ustar00rootroot00000000000000include include include include define MAX_RANGES 100 # FITSCOPY -- Accumulate 2 or more input FITS file into one multiple # extension file or append several FITS units to another FITS file procedure t_fxcopy() char input_file[SZ_PATHNAME] char output_file[SZ_PATHNAME] char imtlist[SZ_LINE], lbrk char group_list[SZ_LINE] int group_range[2*MAX_RANGES+1] int nch, in, out, gn, ninfiles, nitems, list int imtopen(), imtgetim(), imtlen() int lget_next_number(), ldecode_ranges(), stridx() pointer mefi, mefo, fco_open_output(), mef_open() bool clgetb(), new_file, ogrp bool verbose define err_ 99 errchk fcopy begin call clgstr ("input", imtlist, SZ_LINE) call clgstr ("output", output_file, SZ_LINE) new_file = clgetb("new_file") verbose = clgetb("verbose") mefo = fco_open_output (output_file, new_file) out = MEF_FD(mefo) list = imtopen (imtlist) ninfiles = imtlen (list) lbrk = '[' if (ninfiles == 1) ogrp = (stridx (lbrk, imtlist) > 0) # Accumulate 2 or more input FITS files into one mef file or copy # one group from one input file. if (ninfiles > 1 || ogrp) { while (imtgetim (list, input_file, SZ_PATHNAME) != EOF) { mefi = mef_open(input_file, READ_ONLY, 0) # If verbose print the operation. if (verbose) { call eprintf ("%s -> %s\n") call pargstr (input_file) call pargstr (output_file) } # Copy input file to either new or existent file. if (new_file) { if (MEF_ENUMBER(mefi) >= 0) call mef_copy_extn (mefi, mefo, MEF_ENUMBER(mefi)) else call fcopyo (MEF_FD(mefi), MEF_FD(mefo)) MEF_ACMODE(mefo) = APPEND new_file = false } else { if (MEF_ENUMBER(mefi) >= 0) call mef_copy_extn (mefi, mefo, MEF_ENUMBER(mefi)) else call mef_app_file (mefi, mefo) } call mef_close (mefi) } call mef_close (mefo) call imtclose (list) } else { # Copy selected extensions from one input file to the output file. call clgstr ("groups", group_list, SZ_LINE) # Since ranges handles only positive numbers, see if we need # to look for zero group (PHDU). if (ldecode_ranges (group_list,group_range,MAX_RANGES,nitems) ==ERR) call error (0, "Illegal file number list.") list = imtopen (imtlist) nch = imtgetim (list, input_file, SZ_PATHNAME) mefi = mef_open (input_file, READ_ONLY, 0) in = MEF_FD(mefi) # If no input group list is specified, copy the whole file. if (group_list[1] == EOS) { if (verbose) { call eprintf ("%s -> %s\n") call pargstr (input_file) call pargstr (output_file) } call fcopyo (in, out) } else { gn = -1 while (lget_next_number (group_range, gn) != EOF) { call mef_copy_extn (mefi, mefo, gn) if (verbose) { call eprintf ("%s[%d] -> %s\n") call pargstr (input_file) call pargi(gn) call pargstr (output_file) } } } err_ call close (in) call close (out) call imtclose (list) } end # FCOP_OPEN_OUTPUT -- Open output file and return the mef descriptor. pointer procedure fco_open_output (output_file, new_file) char output_file[ARB] #I, output filename bool new_file #I, true if file already exists pointer mef, mef_open() int access(), acmode errchk mef_open begin if (!new_file) { # See if the file exists else change mode. if (access (output_file, 0, 0) == NO) new_file = true } acmode = APPEND if (new_file) { call fclobber (output_file) acmode = NEW_FILE } mef = mef_open (output_file, acmode, 0) if (MEF_ENUMBER(mef) != -1) call error(13, "Extension number not allowed in filename") return (mef) end fitsutil-2018.07.06/src/fxdelete.par000066400000000000000000000001671332007674300170660ustar00rootroot00000000000000# fdelete parameters input,s,a,,,,Input list groups,s,a,,,,List of extensions verbose,b,h,yes,,,Verbose mode,s,h,ql,,, fitsutil-2018.07.06/src/fxdelete.x000066400000000000000000000077641332007674300165650ustar00rootroot00000000000000include include include include include include define MAX_RANGES 100 # FDELETE -- Delete one or more extension in place from a given list # of FITS files. procedure t_fxdelete() char input_file[SZ_FNAME] char imtlist[SZ_FNAME], lbrk char group_list[SZ_LINE], temp[SZ_FNAME] int group_range[2*MAX_RANGES+1] int nch, in, gn, ninfiles, nitems, list, i, outfd int ig, k, fsize, lbrkdx, ngroups, stat bool clgetb() int imtopen(), imtgetim(), imtlen(), open(), read() int lget_next_number(), ldecode_ranges(), stridx(), fnroot(), mef_totpix() int fstatl(), mef_rdhdr_gn() pointer mef, mef_open(), sp, buf, gp, bp, gsk, gnb bool verbose errchk fcopy begin lbrk = '[' call smark (sp) call salloc (buf, FITS_BLKSZ_CHAR, TY_CHAR) call clgstr ("input", imtlist, SZ_FNAME) verbose = clgetb("verbose") list = imtopen (imtlist) ninfiles = imtlen (list) # Find out if we have a bracket indicating an extension number. while (imtgetim (list, input_file, SZ_PATHNAME) != EOF) { lbrkdx = stridx (lbrk, input_file) if (lbrkdx <= 0) break } call imtrew (list) # Read group list nitems = 1 if (lbrkdx <= 0) { call clgstr ("groups", group_list, SZ_LINE) if (ldecode_ranges (group_list,group_range,MAX_RANGES,nitems) ==ERR) call error (0, "Illegal file number list.") if (group_list[1] == EOS) call error (0, "cannot delete PHU (group 0) from file.") call salloc (gp, nitems+1, TY_INT) gn = -1 k = 0 # If group is zero, ignore; we are not going to delete # group zero. while (lget_next_number (group_range, gn) != EOF) { Memi[gp+k] = gn k = k + 1 } } call salloc (gsk, nitems+1, TY_INT) call salloc (gnb, nitems+1, TY_INT) while (imtgetim (list, input_file, SZ_PATHNAME) != EOF) { mef = mef_open (input_file, READ_WRITE, 0) in = MEF_FD(mef) lbrkdx = stridx(lbrk, input_file) ig = MEF_ENUMBER(mef) # Do not delete PHU if (ig == 0) { call mef_close (mef) next } if (lbrkdx > 0) input_file[lbrkdx] = EOS i = fnroot (input_file, temp, SZ_FNAME) call mktemp (temp, temp, SZ_FNAME) call strcat (".fits", temp, SZ_FNAME) outfd = open (temp, NEW_FILE, BINARY_FILE) if (verbose) { call eprintf ("File: %s, deleting extension numbers: ") call pargstr (input_file) } fsize = fstatl (MEF_FD(mef), F_FILESIZE) bp = 0 if (lbrkdx > 0) ngroups = 0 else ngroups = nitems - 1 # Preread the file and mark the groups to delete, the offset # points and the number of blocks to copy to the temporary file. do i = 0, ngroups { if (lbrkdx > 0) gn = ig else gn = Memi[gp+i] stat = mef_rdhdr_gn (mef, gn) Memi[gsk+i] = bp Memi[gnb+i] = (MEF_HOFF(mef) - bp)/1440 bp = MEF_POFF(mef) # If we have a header with no pixels, the pixel offset will # be at the end of the last header block. if (bp == INDEFI) bp = MEF_HOFF(mef) + ((MEF_HSIZE(mef)+2879)/2880)*1440 bp = bp + mef_totpix (mef) } # Now copy those groups that are not being deleted into # the temporary file. do i = 0, ngroups { if (lbrkdx > 0) gn = ig else gn = Memi[gp+i] if (verbose) { call eprintf ("%d ") call pargi(gn) } if (Memi[gsk+i] == 0) call seek (in, BOF) else call seek (in, Memi[gsk+i]) do k = 1, Memi[gnb+i] { nch = read (in, Memc[buf], 1440) call write (outfd, Memc[buf], 1440) } } #end do # Skip the last group data we want to delete call seek (in, bp) # Copy the rest of the file if necessary if (bp < fsize) call fcopyo (in, outfd) if (verbose) call eprintf ("\n") call mef_close (mef) call close (outfd) call delete (input_file) call rename (temp, input_file) } #end while call sfree(sp) end fitsutil-2018.07.06/src/fxdummyh.par000066400000000000000000000001441332007674300171220ustar00rootroot00000000000000# fdummyh parameters filename,f,a,,,,New FITS filename hdr_file,f,h,'',,,Header file mode,s,h,ql,,, fitsutil-2018.07.06/src/fxdummyh.x000066400000000000000000000007641332007674300166170ustar00rootroot00000000000000include include include # MEFCRFITS -- Creates dummy main fits header. procedure t_fxdummyh() pointer sp, path, mef, hdrf pointer mef_open() begin call smark(sp) call salloc (path, SZ_FNAME, TY_CHAR) call salloc (hdrf, SZ_FNAME, TY_CHAR) call clgstr ("filename", Memc[path], SZ_FNAME) call clgstr ("hdr_file", Memc[hdrf], SZ_FNAME) mef = mef_open(Memc[path], NEW_FILE, 0) call mef_dummyhdr (MEF_FD(mef), Memc[hdrf]) call mef_close(mef) call sfree(sp) end fitsutil-2018.07.06/src/fxextract.par000066400000000000000000000003541332007674300172740ustar00rootroot00000000000000# fxextract parameters input,s,a,,,,Input list output,f,a,,,,Output filename groups,s,a,,,,List of extensions use_extnm,b,h,no,,,Use EXTNAME as output filename? phu,b,h,yes,,,Create a dummy PHU? verbose,b,h,yes,,,Verbose mode,s,h,ql,,, fitsutil-2018.07.06/src/fxextract.x000066400000000000000000000137031332007674300167630ustar00rootroot00000000000000include include include include include define MAX_RANGES 100 define SZ_EXTN 4 # FXEXTRACT -- Extract 1 or more extensions into single FITS files. The options # is to have the output files with or without PHU. procedure t_fxextract() char input_file[SZ_PATHNAME] char output_file[SZ_PATHNAME] char imtlist[SZ_LINE], lbrk char group_list[SZ_LINE] int group_range[2*MAX_RANGES+1] int nch, gn, ninfiles, nitems, list, ip, ogrp int imtopen(), imtgetim(), imtlen() int lget_next_number(), ldecode_ranges(), stridx(), ctoi() pointer mefi, mefo, fxx_open_output(), mef_open() pointer sp, op bool clgetb(), use_extnm bool verbose, phu errchk fcopy begin call smark (sp) call salloc (op, SZ_PATHNAME, TY_CHAR) call clgstr ("input", imtlist, SZ_LINE) call clgstr ("output", output_file, SZ_LINE) use_extnm = clgetb("use_extnm") phu = clgetb("phu") verbose = clgetb("verbose") list = imtopen (imtlist) ninfiles = imtlen (list) ogrp = -1 lbrk = '[' if (ninfiles == 1) { ip = stridx (lbrk, imtlist) if (ip > 0) nch = ctoi (imtlist, ip+1, ogrp) } # Ignore group_list parameter if more that one input file. # Make sure there is a group number in each input filename. if (ninfiles > 1) { ip = 1 while (imtgetim (list, input_file, SZ_PATHNAME) != EOF) { ip = stridx (lbrk, input_file[ip]) if (ip == 0) { call eprintf("Input file '%s' ") call pargstr(input_file) call eprintf(" need to have extension number.\n") call erract (EA_FATAL) } } call imtrew (list) } # Extract individuals extensions from each input file in the list. if (ninfiles > 1 || ogrp >= 0) { while (imtgetim (list, input_file, SZ_PATHNAME) != EOF) { mefi = mef_open(input_file, READ_ONLY, 0) call strcpy (output_file, Memc[op], SZ_LINE) ogrp = MEF_ENUMBER(mefi) mefo = fxx_open_output (Memc[op], mefi, use_extnm, ninfiles, ogrp) if (!phu) MEF_KEEPXT(mefo) = YES # If verbose print the operation. if (verbose) { call eprintf ("%s -> %s\n") call pargstr (input_file) call pargstr (Memc[op]) } if (phu) { call mef_dummyhdr (MEF_FD(mefo), NULL) MEF_KEEPXT(mefo) = YES } call mef_copy_extn (mefi, mefo, MEF_ENUMBER(mefi)) call mef_close (mefi) call mef_close (mefo) } call imtclose (list) } else { # Copy selected extensions from one input file to individuals # output files. call clgstr ("groups", group_list, SZ_LINE) if (group_list[1] == EOS) { call eprintf ("Error: parameter 'group' is empty.\n") call erract(EA_FATAL) } # Since ranges handles only positive numbers, see if we need # to look for zero group (PHDU). if (ldecode_ranges (group_list,group_range,MAX_RANGES,nitems) ==ERR) call error (0, "Illegal file number list.") list = imtopen (imtlist) nch = imtgetim (list, input_file, SZ_PATHNAME) mefi = mef_open (input_file, READ_ONLY, 0) call strcpy (output_file, Memc[op], SZ_LINE) gn = -1 while (lget_next_number (group_range, gn) != EOF) { mefo = fxx_open_output (Memc[op], mefi, use_extnm, nitems, gn) if (!phu) MEF_KEEPXT(mefo) = YES call mef_copy_extn (mefi, mefo, gn) if (verbose) { call eprintf ("%s[%d] -> %s\n") call pargstr (input_file) call pargi(gn) call pargstr (Memc[op]) } call mef_close (mefo) # Restore output name with no group_number call strcpy (output_file, Memc[op], SZ_LINE) } call imtclose (list) } call sfree(sp) end # FXX_OPEN_OUTPUT -- Open new output file and return the mef descriptor. pointer procedure fxx_open_output (output_file, mefi, use_extnm, ninf, gn) char output_file[ARB] #I output filename pointer mefi #I input mef descriptor bool use_extnm #I true if want to use EXTNAME int ninf #I Number of input files int gn #I Group number pointer mef, sp, root, extn pointer mef_open() char name[SZ_FNAME], dirname[SZ_FNAME] int len, lenr, lend, junk, null_root, stat int fnroot(), fnextn(), itoc(), fnldir(), mef_rdhdr_gn() errchk mef_open begin lend = fnldir (output_file, dirname, SZ_FNAME) if (use_extnm) { stat = mef_rdhdr_gn (mefi, gn) call mefgstr (mefi, "EXTNAME", name, LEN_CARD) if (name[1] != EOS) { # Get root name only len = fnroot (name, name, LEN_CARD) if (len > 0) name[len+1] = EOS else { # EXTNAME did not contain a root name, choose input # filename as root. len = fnroot (MEF_FNAME(mefi), name, LEN_CARD) } }else { # EXTNAME was empty. Use input filename and add the extension # number. len = fnroot (MEF_FNAME(mefi), name, LEN_CARD) len = itoc (MEF_ENUMBER(mefi), name[len+1], LEN_CARD) } output_file[1] = EOS if (lend > 0) call strcpy (dirname, output_file, SZ_FNAME) call strcat (name, output_file, SZ_FNAME) call strcat (".fits", output_file, LEN_CARD) mef = mef_open (output_file, NEW_FILE, 0) } else { call smark (sp) call salloc (root, SZ_FNAME, TY_CHAR) call salloc (extn, SZ_EXTN, TY_CHAR) call strcpy (output_file[lend+1], name, SZ_FNAME) null_root = NO if (name[1] == EOS) { call strcpy (MEF_FNAME(mefi), name, SZ_FNAME) null_root = YES } lenr = fnroot (name, Memc[root], SZ_FNAME) len = fnextn (name, Memc[extn], SZ_EXTN) if (Memc[extn] == EOS) call strcpy ("fits", Memc[extn], SZ_EXTN) # Append group number to root if (gn >= 0 && null_root == YES || ninf > 1) junk = itoc (gn, Memc[root+lenr], SZ_FNAME) call strcpy (dirname, output_file, SZ_FNAME) call strcat (Memc[root], output_file, SZ_FNAME) call strcat (".", output_file, SZ_FNAME) call strcat (Memc[extn], output_file, SZ_FNAME) mef = mef_open (output_file, NEW_FILE, 0) call sfree(sp) } return (mef) end fitsutil-2018.07.06/src/fxheader.par000066400000000000000000000003021332007674300170430ustar00rootroot00000000000000# CMEF parameters fits_file,f,a,,,,FITS data source format_file,s,h,"",,,Output format file? long_header,b,h,no,,,Print long header? count_lines,b,h,no,,,Long header line number? mode,s,h,ql,,, fitsutil-2018.07.06/src/fxheader.x000066400000000000000000000042371332007674300165430ustar00rootroot00000000000000include include define SZ_CARD 80 # FHEADER -- Procedure to catalog a fits file from disk. The user can select # one line output or the entire header. The user can select the fields to print # in the one line output through a an ascii file with format information. procedure t_fxheader() char infile[SZ_FNAME] # fits file char in_fname[SZ_FNAME] # input file name char format_file[SZ_FNAME] # input file name with format information # for one line output per fits file. pointer list int lenlist int file_number, stat char ksection[SZ_CARD], dnap[SZ_CARD] bool clgetb(), count_lines int btoi(), imtgetim(), group int imtlen(), itmp pointer imtopen() int short_header, long_header, cat_print_header() begin # Set up the standard output to flush on a newline call fseti (STDOUT, F_FLUSHNL, YES) # Get RFITS parameters. call clgstr ("fits_file", infile, SZ_FNAME) long_header = btoi (clgetb ("long_header")) count_lines = clgetb("count_lines") short_header = YES if (long_header == YES) short_header = NO list = imtopen (infile) lenlist = imtlen (list) # Get format file name if short_header is selected if (short_header == YES) { call clgstr ("format_file", format_file, SZ_FNAME) if (format_file[1] == EOS) call strcpy ("fitsutil$format.mip", format_file, SZ_FNAME) call dfread_formats (format_file) # Print the keywords in format_file as one line title. call print_titles } # See if extension number has been specified. file_number = 0 while (imtgetim (list, in_fname, SZ_FNAME) != EOF) { call imparse (in_fname, infile, SZ_FNAME, ksection, SZ_CARD, dnap, SZ_CARD, group, itmp) if (group != -1) { call sprintf(in_fname, SZ_FNAME, "%s[%d]") call pargstr(infile) call pargi(group) call strcpy(in_fname, infile, SZ_FNAME) } if (stat == -3) call printf("\n") # NL if mef iferr (stat = cat_print_header (infile, file_number, count_lines, short_header, ksection) ) call erract(EA_WARN) # break file_number = file_number + 1 } if (list != NULL) call imtclose (list) end fitsutil-2018.07.06/src/fxinsert.par000066400000000000000000000002211332007674300171170ustar00rootroot00000000000000# finsert parameters input,s,a,,,,Input list output,f,a,,,,Output file groups,s,a,,,,List of extensions verbose,b,h,yes,,,Verbose mode,s,h,ql,,, fitsutil-2018.07.06/src/fxinsert.x000066400000000000000000000065621332007674300166220ustar00rootroot00000000000000include include include include define MAX_RANGES 100 # FINSERT -- Insert one or more extension into the output file. procedure t_fxinsert() char input_file[SZ_FNAME] char output_file[SZ_FNAME] char imtlist[SZ_FNAME], lbrk char group_list[SZ_LINE], temp[SZ_FNAME] int group_range[2*MAX_RANGES+1] int in, out, gn, ninfiles, nitems, list, i, outfd int ig, nblks, nchars, stat int imtopen(), imtgetim(), imtlen(), open(), read(), mef_rdhdr_gn() int lget_next_number(), ldecode_ranges(), stridx(), fnroot(), note() pointer mefi, mefo, mef_open(), sp, buf bool clgetb(), ogrp bool verbose errchk fcopy begin lbrk = '[' call smark (sp) call salloc (buf, FITS_BLKSZ_CHAR, TY_CHAR) call clgstr ("input", imtlist, SZ_LINE) call clgstr ("output", output_file, SZ_FNAME) verbose = clgetb("verbose") mefo = mef_open (output_file, READ_WRITE, 0) if (MEF_ENUMBER(mefo) < 0) call error (13,"Output extension number not given") out = MEF_FD(mefo) # Position output file to the insertion point. We endup with the file # pointer at the end of the group. stat = mef_rdhdr_gn (mefo, MEF_ENUMBER(mefo)) nblks = (note(out) - 1) / FITS_BLKSZ_CHAR # Make a temporary filename. i = stridx(lbrk, output_file) if (i > 0) output_file[i] = EOS i = fnroot (output_file, temp, SZ_FNAME) call mktemp (temp, temp, SZ_FNAME) outfd = open (temp, NEW_FILE, BINARY_FILE) MEF_FD(mefo) = outfd # Copy data into temporary file. call seek (out, BOF) do i = 1, nblks { nchars = read (out, Memc[buf], FITS_BLKSZ_CHAR) call write (outfd, Memc[buf], FITS_BLKSZ_CHAR) } call flush (outfd) list = imtopen (imtlist) ninfiles = imtlen (list) ogrp = false # Copy selected extensions from one input file to the output file. call clgstr ("groups", group_list, SZ_LINE) if (ldecode_ranges (group_list,group_range,MAX_RANGES,nitems) ==ERR) call error (0, "Illegal file number list.") while (imtgetim (list, input_file, SZ_PATHNAME) != EOF) { mefi = mef_open (input_file, READ_ONLY, 0) in = MEF_FD(mefi) ogrp = (stridx (lbrk, input_file) > 0) if (verbose && (ogrp || group_list[1] == EOS)) { call eprintf ("%s -> %s\n") call pargstr (input_file) call pargstr (output_file) } # If an extension is specified, copy that only. if (ogrp) { ig = MEF_ENUMBER(mefi) if (ig >= 0) call mef_copy_extn (mefi, mefo, ig) else call mef_app_file (mefi, mefo) } else if (group_list[1] == EOS ) { # No input group list is specified, copy the whole file. call mef_copy_extn (mefi, mefo, 0) call fcopyo (in, outfd) } else { gn = -1 while (lget_next_number (group_range, gn) != EOF) { call mef_copy_extn (mefi, mefo, gn) if (verbose) { call eprintf ("%s[%d] -> %s\n") call pargstr (input_file) call pargi(gn) call pargstr (output_file) } } } call mef_close (mefi) } # End While call close (in) # Now append the rest of the old output file into the temp file call seek (out, nblks * FITS_BLKSZ_CHAR + 1) call fcopyo (out, outfd) call close (out) call mef_close (mefo) call delete (output_file) call rename (temp, output_file) call imtclose (list) call sfree(sp) end fitsutil-2018.07.06/src/fxplf.par000066400000000000000000000001561332007674300164030ustar00rootroot00000000000000# fxplf parameters input,s,a,,,,Input list output,f,a,,,,Output file verbose,b,h,yes,,,Verbose mode,s,h,ql,,, fitsutil-2018.07.06/src/fxplf.x000066400000000000000000000041251332007674300160700ustar00rootroot00000000000000# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include include include include include define INC_HDRMEM 8100 # FXPLF -- Procedure to convert a 'pl' file into a # BINTABLE extension into a FITS file. procedure t_fxplf() char output[SZ_LINE], stitle[SZ_LINE], input[SZ_LINE] pointer sp, fname, hp, pl, bp, mef pointer mef_open(), pl_open() int masklen, buflen, ctime,mtime, limtime int naxes, axlen[7], depth, list, ninfiles, oldfile int imtopen(), imtgetim(), imtlen(), access() int flags, pl_save() real minval, maxval bool verbose, clgetb() begin call smark (sp) call salloc (fname, SZ_PATHNAME, TY_CHAR) call salloc (hp, INC_HDRMEM, TY_CHAR) call clgstr ("input", Memc[fname], SZ_LINE) call clgstr ("output", output, SZ_LINE) verbose = clgetb("verbose") list = imtopen (Memc[fname]) ninfiles = imtlen (list) oldfile = YES if (access(output, 0,0) == NO) { mef = mef_open(output, NEW_FILE, NULL) call mef_dummyhdr (MEF_FD(mef), NULL) oldfile = NO } else { mef = mef_open(output, APPEND, NULL) } MEF_ACMODE(mef) = APPEND while (imtgetim (list, input, SZ_PATHNAME) != EOF) { # Open an empty mask. pl = pl_open (NULL) # Load the named mask if opening an existing mask image. iferr (call pl_loadf (pl, input, Memc[hp], INC_HDRMEM)) { call pl_close (pl) call sfree (sp) call eprintf("Error loading input pl file\n") return } bp = NULL masklen = pl_save (pl, bp, buflen, flags) call pl_gsize (pl, naxes, axlen, depth) if (verbose) { if (oldfile == NO) { call eprintf ("%s -> %s\n") oldfile = YES } else call eprintf ("%s -> %s[append]\n") call pargstr (input) call pargstr (output) } call mef_setpl (PLIO_SVMAGIC, masklen, Memc[hp], stitle, ctime, mtime, limtime, minval, maxval, mef) call mef_wrpl (mef, stitle, ctime,mtime, limtime, minval, maxval,Mems[bp], naxes, axlen) call mfree (bp, TY_SHORT) } call mef_close (mef) call sfree (sp) end fitsutil-2018.07.06/src/fxsplit.par000066400000000000000000000001261332007674300167520ustar00rootroot00000000000000# fxsplit parameters input,s,a,,,,Input list verbose,b,h,yes,,,Verbose mode,s,h,ql,,, fitsutil-2018.07.06/src/fxsplit.x000066400000000000000000000027051332007674300164440ustar00rootroot00000000000000include include include include # FXSPLIT -- Split a MEF file into individual single FITS files. procedure t_fxsplit() char input_file[SZ_FNAME] char output_file[SZ_FNAME] char imtlist[SZ_FNAME] char root[SZ_FNAME], extn[4] int i, gn, ninfiles, list int imtopen(), imtgetim(), imtlen() int fnextn(), fnroot() pointer mefi, mefo, mef_open() bool clgetb() bool verbose define err_ 99 errchk fcopy begin call clgstr ("input", imtlist, SZ_FNAME) verbose = clgetb("verbose") list = imtopen (imtlist) ninfiles = imtlen (list) while (imtgetim (list, input_file, SZ_FNAME) != EOF) { mefi = mef_open(input_file, READ_ONLY, 0) i = fnextn (input_file, extn, 4) i = fnroot (input_file, root, SZ_FNAME) if (extn[1] == EOS) call strcpy ("fits", extn, 4) do gn = 0, MAX_INT { call sprintf (output_file, SZ_FNAME, "%s%d.%s") call pargstr(root) call pargi(gn) call pargstr(extn) mefo = mef_open (output_file, NEW_FILE, 0) iferr (call mef_copy_extn (mefi, mefo, gn)) { call mef_close (mefo) call delete (output_file) break } # If verbose print the operation. if (verbose) { call eprintf ("%s -> %s\n") call pargstr (input_file) call pargstr (output_file) } call mef_close (mefo) } call mef_close (mefi) } call imtclose (list) end fitsutil-2018.07.06/src/getcmd.x000066400000000000000000000223661332007674300162230ustar00rootroot00000000000000include include include include # parameter names and values. define HS_ADD 1 define HS_ADDONLY 2 define HS_UPDATE 3 define HS_VERIFY 4 define HS_SHOW 5 define HS_DELETE 6 define HS_FIELD 7 define HS_VALUE 8 define HS_COMMENT 9 define HS_BEFORE 10 define HS_AFTER 11 define ERROR -2 define HADD Memi[$1] define HADDONLY Memi[$1+1] define HUPDATE Memi[$1+2] define HVERIFY Memi[$1+3] define HSHOW Memi[$1+4] define HDELETE Memi[$1+5] define HBAF Memi[$1+6] define HFIELD Memc[P2C($1+10)] define HVALUE Memc[P2C($1+46)] define HCOMMENT Memc[P2C($1+86)] define HBAFVALUE Memc[P2C($1+126)] define HSZ 200 define OP_EDIT 1 # hedit opcodes define OP_INIT 2 define OP_ADD 3 define OP_DELETE 4 define OP_DEFPAR 5 define BEFORE 1 define AFTER 2 define LEN_CARD 80 # HE_CMDPARS -- Procedure to parse and analyze a string of the form: # procedure he_getcmdf (cmd, operation, fields, valexpr, comment, pkey, baf, update, verify, show) char cmd[ARB] #I String with kernel section int operation char fields[ARB] char valexpr[ARB] char comment[ARB] char pkey[ARB] int baf int update int verify int show pointer hc char outstr[LEN_CARD] char identif[LEN_CARD], dot int ip, nexpr, token, add, addonly, delete, nch bool streq() int lex_type, ctotok(), he_ks_lex(), ctowrd() errchk syserr, syserrs begin # The default values should have been already initialized # with a call fxf_ksinit(). call calloc(hc, HSZ, TY_STRUCT) call he_ksinit (hc) ip = 1 nexpr = 0 identif[1] = EOS repeat { # Advance to the next keyword. if (ip == 1) { nch= ctowrd(cmd, ip, outstr, LEN_CARD) token = TOK_IDENTIFIER } else { token = ctotok (cmd, ip, outstr, LEN_CARD) } if (token == TOK_CHARCON) { ip = ip - 2 nch= ctowrd(cmd, ip, outstr, LEN_CARD) if (nexpr >= 1) token = TOK_STRING if (nch <=3) { #ctowrd will not parse one letter string, doit in here. outstr[1]=cmd[ip-2] outstr[2]=EOS } } if (token == TOK_STRING && nexpr == 0) token = TOK_IDENTIFIER switch (token) { case TOK_EOS: break case TOK_NEWLINE: break case TOK_NUMBER: if (nexpr != 1) call error (13,"Numeric value not allow in this field") call strcpy (outstr, HVALUE(hc), LEN_CARD) nexpr = nexpr + 1 case TOK_CHARCON: ip = ip - 1 case TOK_STRING: if (nexpr != 1 && nexpr != 2) call error(13, "Value or comment error") if (nexpr == 1) call strcpy (outstr, HVALUE(hc), LEN_CARD) if (nexpr == 2) call strcpy (outstr, HCOMMENT(hc), LEN_CARD) nexpr = nexpr + 1 case TOK_IDENTIFIER: call strcpy (outstr, identif, LEN_CARD] call strlwr (outstr) lex_type = he_ks_lex (outstr) if (streq(identif, "comment") && nexpr == 0) lex_type = 0 # look for =, + or - if (lex_type > 0) { call he_ks_gvalue (lex_type, cmd, ip, hc) } else { #if (nexpr == 0 || nexpr == 1) if (nexpr == 0) call strcpy (identif, HFIELD(hc), LEN_CARD) else if (nexpr == 1) call strcpy (outstr, HVALUE(hc), LEN_CARD) else call error(13, "Field or value error") } nexpr = nexpr + 1 case TOK_OPERATOR: dot = outstr[1] if (nexpr == 1 && dot == '.') call strcpy (outstr, HVALUE(hc), LEN_CARD) else if (nexpr == 2 && dot == '.') call strcpy (outstr, HCOMMENT(hc), LEN_CARD) else call error(13,"error in tok_operator value") nexpr = nexpr + 1 default: #call error(13,"error in command line") } } call strcpy (HFIELD(hc), fields, LEN_CARD) call strcpy (HVALUE(hc), valexpr, LEN_CARD) call strcpy (HCOMMENT(hc), comment, LEN_CARD) call strcpy (HBAFVALUE(hc), pkey, LEN_CARD) baf = HBAF(hc) add = HADD(hc) addonly = HADDONLY(hc) update = HUPDATE(hc) verify = HVERIFY(hc) show = HSHOW(hc) delete = HDELETE(hc) #operation = OP_EDIT operation = -1 if (add == YES) operation = OP_ADD else if (addonly == YES) operation = OP_INIT else if (delete == YES) operation = OP_DELETE if (streq (fields, "default_pars")) { operation = -operation } else if (operation < 0) { operation = OP_DEFPAR } call mfree(hc, TY_STRUCT) end # HE_KS_LEX -- Map an identifier into a header parameter code. int procedure he_ks_lex (outstr) char outstr[ARB] int len, strlen(), strncmp() errchk syserr, syserrs begin len = strlen (outstr) # Allow for small string to be taken as keyword names # and not hedit parameters, like 'up' instead of 'up(date)'. if (len < 3) return(0) # Other kernel keywords. if (strncmp (outstr, "field", len) == 0) return (HS_FIELD) if (strncmp (outstr, "value", len) == 0) return (HS_VALUE) if (strncmp (outstr, "comment", len) == 0) return (HS_COMMENT) if (strncmp (outstr, "after", len) == 0) return (HS_AFTER) if (strncmp (outstr, "before", len) == 0) return (HS_BEFORE) if (strncmp (outstr, "add", len) == 0) return (HS_ADD) if (strncmp (outstr, "addonly", len) == 0) return (HS_ADDONLY) if (strncmp (outstr, "delete", len) == 0) return (HS_DELETE) if (strncmp (outstr, "verify", len) == 0) return (HS_VERIFY) if (strncmp (outstr, "show", len) == 0) return (HS_SHOW) if (strncmp (outstr, "update", len) == 0) return (HS_UPDATE) return (0) # not recognized; probably a value end # FXF_KS_GVALUE -- Given a parameter code get its value at the 'ip' character # position in the 'ksection' string. Put the values in the FKS structure. procedure he_ks_gvalue (param, cmd, ip, hc) int param #I parameter code char cmd[ARB] #I Ksection int ip #I Current parsing pointer in ksection pointer hc #U Update the values in the FKS structure pointer sp, ln int jp, token int ctotok() errchk syserr, syserrs begin jp = ip call smark (sp) call salloc (ln, LEN_CARD, TY_CHAR) # See if the parameter value is given as par= or '+/-' if (ctotok (cmd, jp, Memc[ln], LEN_CARD) == TOK_OPERATOR) { if (Memc[ln] == '=' ) { token = ctotok (cmd, jp, Memc[ln], LEN_CARD) if (token != TOK_IDENTIFIER && token != TOK_STRING && token != TOK_NUMBER) { call syserr (SYS_FXFKSSYN) } else { call he_ks_val (Memc[ln], param, hc) ip = jp } } else if (Memc[ln] == '+' || Memc[ln] == '-') { call he_ks_pm (Memc[ln], param, hc) ip = jp } } call sfree (sp) end # FXF_KS_VALUE -- Returns the value of a parameter in the kernel section. procedure he_ks_val (outstr, param, hc) char outstr[ARB] #I Input string with value int param #I Parameter code pointer hc #U Fits kernel descriptor int ival int strcmp() errchk syserr, syserrs begin call strlwr (outstr) if (strcmp (outstr, "yes") == 0) ival = YES else if (strcmp (outstr, "no") == 0) ival = NO else ival = ERROR switch (param) { case HS_FIELD: call strcpy (outstr, HFIELD(hc), LEN_CARD) case HS_VALUE: call strcpy (outstr, HVALUE(hc), LEN_CARD) case HS_COMMENT: call strcpy (outstr, HCOMMENT(hc), LEN_CARD) case HS_BEFORE: HBAF(hc) = BEFORE call strcpy (outstr, HBAFVALUE(hc), LEN_CARD) case HS_AFTER: HBAF(hc) = AFTER call strcpy (outstr, HBAFVALUE(hc), LEN_CARD) case HS_ADD: HADD(hc) = ival case HS_ADDONLY: HADDONLY(hc) = ival case HS_UPDATE: HUPDATE(hc) = ival case HS_VERIFY: HVERIFY(hc) = ival case HS_SHOW: HSHOW(hc) = ival case HS_DELETE: HDELETE(hc) = ival default: call syserr (SYS_FXFKSSYN) } end # HE_KS_PM -- Return the character YES or NO based on the value '+' or '-' procedure he_ks_pm (pm, param, hc) char pm[1] #I contains "+" or "-" int param #I Parameter code pointer hc #U Fits kernel descriptor int ival errchk syserr, syserrs begin if (pm[1] == '+') ival = YES else ival = NO switch (param) { case HS_ADD: HADD(hc) = ival case HS_ADDONLY: HADDONLY(hc) = ival case HS_UPDATE: HUPDATE(hc) = ival case HS_VERIFY: HVERIFY(hc) = ival case HS_SHOW: HSHOW(hc) = ival case HS_DELETE: HDELETE(hc) = ival default: call error(13, "ks_pm: invalid value") } end # FXF_KSINIT -- Initialize default values for ks parameters. procedure he_ksinit (hc) pointer hc #I begin HADD(hc) = NO HADDONLY(hc) = NO HUPDATE(hc) = -1 HVERIFY(hc) = -1 HSHOW(hc) = -1 HDELETE(hc) = NO #HUPDATE(hc) = YES #HVERIFY(hc) = NO #HSHOW(hc) = NO end fitsutil-2018.07.06/src/kwdb.c000066400000000000000000000706171332007674300156640ustar00rootroot00000000000000#include #include #include "kwdb.h" /* * KWDB -- Keyword Database interface. * * The KWDB is a simple keyword/value interface which buffers a list of * keywords in memory within the KWDB. * * KWDB routines: * * kwdb = kwdb_Open (kwdbname) * name = kwdb_Name (kwdb) * nkw = kwdb_Len (kwdb) * kwdb_Close (kwdb) * * kwdb_AddEntry (kwdb, keyword, value, type, comment) * value = kwdb_GetValue (kwdb, keyword) * kwdb_SetValue (kwdb, keyword, value) * kwdb_SetComment (kwdb, keyword, comment) * str = kwdb_GetComment (kwdb, keyword) * kwdb_SetType (kwdb, keyword, type) * type = kwdb_GetType (kwdb, keyword) * * ep = kwdb_Lookup (kwdb, keyword, instance) * ep = kwdb_Head (kwdb) * ep = kwdb_Tail (kwdb) * ep = kwdb_Next (kwdb, ep) * kwdb_DeleteEntry (kwdb, ep) * kwdb_RenameEntry (kwdb, ep, newname) * kwdb_CopyEntry (kwdb, o_kwdb, o_ep, newname) * count = kwdb_GetEntry (kwdb, ep, keyword, value, type, comment) * name = kwdb_KWName (kwdb, ep) * * Associated utility routines: * * kwdb = kwdb_OpenFITS (filename, maxcards, nblank) * kwdb_UpdateFITS (kwdb, filename, update, extend, npad) * count = kwdb_ReadFITS (kwdb, fd, maxcards, nblank) * kwdb_WriteFITS (kwdb, fd) * kwdb_SetIO (kwdb, readfcn, writefcn) * * FITS card types: * * S=string L=logical N=numeric C=comment H=history T=text * * The kwdbname is a string identifying the database. The value of the * string is arbitrary and is not used internally by KWDB. kwdb_Name * returns the value of kwdbname entered in kwdb_Open. kwdb_Len returns * the number of keywords (or other entries including null entries) in the * database. kwdb_Close destroys a database and frees all resources used * by the KWDB. * * KWDB entries are maintained in a FIFO list and may be referenced either * by the entry reference EP or by the keyword name if the entry is a * keyword. Multiple entries with the same keyword name are permitted, in * which case the most recent entry takes precedence. * * kwdb_AddEntry adds an entry to the database. kwdb_GetValue returns the * value of a keyword (as a string) given its name. kwdb_SetValue sets the * value string of a keyword; kwdb_SetComment sets the comment field. * kwdb_Lookup searches the database for the most recent entry for a keyword * and returns the entry reference: zero is returned if the keyword is not * found. * * kwdb_CopyEntry copies an entry from one database to another. * kwdb_DeleteEntry deletes an entry. kwdb_RenameEntry renames an entry: * either the old or new name can be nil. Renaming an entry does not change * its position in the list but if there are redefinitions it becomes the * most recent instance. kwdb_GetEntry gets an entry given the symbol * reference. kwdb_Head returns the entry reference EP of the first entry in * the list. kwdb_Next returns the reference for the next entry after the * current one. * * All keyword values and other fields are stored and manipulated as strings. * There is an associated data type field however which can be used to guide * how the value field is interpreted or presented. The contents of the type * field are up to the application (e.g., "bool", "int", "float", "string"). * * The high level utility routines kwdb_OpenFITS and kwdb_UpdateFITS create * a new KWDB and load the header of a FITS file into it (OpenFITS), and * save a KWDB to a new FITS file or update the header of an existing file * (UpdateFITS). kwdb_ReadFITS and kwdb_WriteFITS read and write FITS cards * to a file stream. kwdb_SetIO can be used to enter private file read and * write functions to be used by ReadFITS/WriteFITS, allowing data other than * host files to be read and written. * * These are the only routines in KWDB which know anything about FITS, the * rest of the interface provides a general purpose symbol table with special * characteristics of FIFO ordering, non-keyword entries, and comment lines * on keywords. */ /* Data structure design. * ---------------------- * hash table * hash to thread table * thread points to head of linked-list of entries * search down list for first matching entry * link new entries at head of list * descriptor array (indexed) * include hash table thread links * sbuf * character storage * append new strings * strings referenced by index */ #define NTHREADS 797 #define DEF_SZSBUF 32768 #define DEF_NKEYWORDS 512 #define MAX_HASHCHARS 18 #define SZ_FILEBUF 102400 #define COM_EP(db,p) ((p)-db->itab) #define REF_EP(db,ep) &db->itab[ep] int primes[] = { 101,103,107,109,113,127,131,137,139, 149,151,157,163,167,173,179,181,191, }; /* KWDB item descriptor. */ struct item { int name; /* item name (optional) */ int value, vallen; /* item value (optional) */ int type, typelen; /* value type (optional) */ int comment, comlen; /* item comment (optional) */ int nexthash; /* next item in hash thread */ int nextglob; /* next item in global list */ }; typedef struct item Item; typedef int (*PFI)(); struct kwdb { int kwdbname; /* database name */ int maxitems; /* capacity of itab */ int nitems; /* number of valid items */ int itemsused; /* number of item slots used */ int sbuflen; /* capacity of sbuf */ int sbufused; /* sbuf characters used */ int head; /* itab index of first item */ int tail; /* itab index of last item */ Item *itab; /* pointer to itab array */ char *sbuf; /* pointer to string buffer */ int hashtbl[NTHREADS]; /* hash table */ int (*read)(); /* private file read function */ int (*write)(); /* private file write function */ }; typedef struct kwdb KWDB; extern char *mkstemp(); extern int read(), write(); static int hash(); static int addstr(); static int streq(); /* * Public functions. * ----------------- */ /* KWDB_OPEN -- Open a new, empty keyword database. */ pointer kwdb_Open (kwdbname) char *kwdbname; { register KWDB *db = NULL; Item *itab = NULL; char *sbuf = NULL; if (!(db = (KWDB *) calloc (1, sizeof(KWDB)))) goto cleanup; if (!(itab = (Item *) calloc (DEF_NKEYWORDS, sizeof(Item)))) goto cleanup; if (!(sbuf = (char *) calloc (DEF_SZSBUF, sizeof(char)))) goto cleanup; sbuf[0] = '\0'; db->kwdbname = 1; strcpy (sbuf+1, kwdbname); db->sbufused = strlen(kwdbname) + 2; db->sbuflen = DEF_SZSBUF; db->sbuf = sbuf; db->maxitems = DEF_NKEYWORDS; db->nitems = 0; db->itemsused = 1; db->head = 0; db->tail = 0; db->itab = itab; db->read = read; db->write = write; return ((pointer) db); cleanup: if (sbuf) free (sbuf); if (itab) free ((char *) itab); if (db) free ((char *) db); return (NULL); } /* KWDB_CLOSE -- Destroy a KWDB database and free all resources. */ void kwdb_Close (kwdb) pointer kwdb; { register KWDB *db = (KWDB *) kwdb; if (db->sbuf) free (db->sbuf); if (db->itab) free ((char *) db->itab); if (db) free ((char *) db); } /* KWDB_NAME -- Return the name of a KWDB database. */ char * kwdb_Name (kwdb) pointer kwdb; { register KWDB *db = (KWDB *) kwdb; return (db->sbuf + db->kwdbname); } /* KWDB_LEN -- Return the number of items in a KWDB database. */ kwdb_Len (kwdb) pointer kwdb; { register KWDB *db = (KWDB *) kwdb; return (db->nitems); } /* KWDB_ADDENTRY -- Append an entry to the keyword database. Any of the * fields keyword, value, type, or comment can be NULL if these fields * have no value. */ kwdb_AddEntry (kwdb, keyword, value, type, comment) pointer kwdb; char *keyword, *value, *type, *comment; { register KWDB *db = (KWDB *) kwdb; register Item *itp, *otp; int index, i; /* Make sure there is space in the item buffer. */ if (db->itemsused >= db->maxitems) { db->maxitems += DEF_NKEYWORDS; itp = (Item *) realloc ((char *)db->itab, sizeof(Item) * db->maxitems); if (!itp) return (-1); db->itab = itp; } index = db->itemsused++; itp = &db->itab[index]; itp->name = addstr (db, keyword); itp->value = addstr (db, value); itp->vallen = value ? strlen(value) : 0; itp->type = addstr (db, type); itp->typelen = type ? strlen(type) : 0; itp->comment = addstr (db, comment); itp->comlen = comment ? strlen(comment) : 0; itp->nexthash = 0; itp->nextglob = 0; /* Link item at head of global list if list empty. */ if (!db->head) db->head = index; /* Link item at tail of global list. */ if (db->tail) { otp = REF_EP(db,db->tail); otp->nextglob = index; } db->tail = index; /* Enter item in hash table. */ if (keyword && *keyword) { int hashval = hash (keyword); if (i = db->hashtbl[hashval]) itp->nexthash = i; db->hashtbl[hashval] = index; } db->nitems++; return (COM_EP(db,itp)); } /* KWDB_LOOKUP -- Lookup a keyword in the database. If there are multiple * values for the same keyword in the database then the instance number * determines which is returned. An instance of zero returns the first * (most recently entered) instance. Successive instances return entries * earlier in the list. Note that this is opposite of an ordered traversal * of the list using kwdb_Head/kwdb_Next, which accesses the list with * oldest entries first. */ kwdb_Lookup (kwdb, keyword, instance) pointer kwdb; char *keyword; int instance; { register KWDB *db = (KWDB *) kwdb; register Item *itp; register int i, j; int hashval; hashval = hash (keyword); if (i = db->hashtbl[hashval]) for (itp = REF_EP(db,i), j=0; i; itp = REF_EP(db,i=itp->nexthash)) if (streq (db->sbuf + itp->name, keyword)) if (instance == j++) return (i); return (0); } /* KWDB_GETVALUE -- Lookup a keyword and returns its value. NULL is returned * if the keyword is not found. */ char * kwdb_GetValue (kwdb, keyword) pointer kwdb; char *keyword; { register KWDB *db = (KWDB *) kwdb; register Item *itp; register int ep; if (ep = kwdb_Lookup (kwdb, keyword, 0)) { itp = REF_EP(db,ep); return (db->sbuf + itp->value); } return (NULL); } /* KWDB_SETVALUE -- Modify the value of a keyword. Zero is returned for a * successul operation, otherwise -1. */ kwdb_SetValue (kwdb, keyword, value) pointer kwdb; char *keyword, *value; { register KWDB *db = (KWDB *) kwdb; register Item *itp = NULL; char *oldval; int ep; if (ep = kwdb_Lookup (kwdb, keyword, 0)) itp = REF_EP(db,ep); else return (-1); oldval = db->sbuf + itp->value; memset (oldval, 0, itp->vallen); if (strlen(value) > itp->vallen) { itp->value = addstr (db, value); itp->vallen = strlen (value); } else strcpy (oldval, value); return (0); } /* KWDB_SETCOMMENT -- Modify the comment field of a keyword. Zero is * returned for a successul operation, otherwise -1. */ kwdb_SetComment (kwdb, keyword, comment) pointer kwdb; char *keyword, *comment; { register KWDB *db = (KWDB *) kwdb; register Item *itp = NULL; char *oldcom; int ep; if (ep = kwdb_Lookup (kwdb, keyword, 0)) itp = REF_EP(db,ep); else return (-1); oldcom = db->sbuf + itp->comment; memset (oldcom, 0, itp->comlen); if (strlen(comment) > itp->comlen) { itp->comment = addstr (db, comment); itp->comlen = strlen (comment); } else strcpy (oldcom, comment); return (0); } /* KWDB_GETCOMMENT -- Lookup a keyword and returns its comment field. NULL * is returned if the keyword is not found. */ char * kwdb_GetComment (kwdb, keyword) pointer kwdb; char *keyword; { register KWDB *db = (KWDB *) kwdb; register Item *itp; register int ep; if (ep = kwdb_Lookup (kwdb, keyword, 0)) { itp = REF_EP(db,ep); return (db->sbuf + itp->comment); } return (NULL); } /* KWDB_SETTYPE -- Modify the data type field of a keyword. Zero is * returned for a successul operation, otherwise -1. */ kwdb_SetType (kwdb, keyword, type) pointer kwdb; char *keyword, *type; { register KWDB *db = (KWDB *) kwdb; register Item *itp = NULL; char *oldtype; int ep; if (ep = kwdb_Lookup (kwdb, keyword, 0)) itp = REF_EP(db,ep); else return (-1); oldtype = db->sbuf + itp->type; memset (oldtype, 0, itp->typelen); if (strlen(type) > itp->typelen) { itp->type = addstr (db, type); itp->typelen = strlen (type); } else strcpy (oldtype, type); return (0); } /* KWDB_GETTYPE -- Lookup a keyword and returns its type field. NULL * is returned if the keyword is not found. */ char * kwdb_GetType (kwdb, keyword) pointer kwdb; char *keyword; { register KWDB *db = (KWDB *) kwdb; register Item *itp; register int ep; if (ep = kwdb_Lookup (kwdb, keyword, 0)) { itp = REF_EP(db,ep); return (db->sbuf + itp->type); } return (NULL); } /* KWDB_HEAD -- Return the entry pointer for the first entry in the database. */ kwdb_Head (kwdb) pointer kwdb; { register KWDB *db = (KWDB *) kwdb; return (db->head); } /* KWDB_TAIL -- Return the entry pointer for the most recent entry in * the database. */ kwdb_Tail (kwdb) pointer kwdb; { register KWDB *db = (KWDB *) kwdb; return (db->tail); } /* KWDB_NEXT -- Return the entry pointer for the next entry in a database, * given a pointer to the preceding entry. Zero is returned at the end of * the database. */ kwdb_Next (kwdb, ep) pointer kwdb; int ep; { register KWDB *db = (KWDB *) kwdb; register Item *itp = NULL; itp = REF_EP(db,ep); return (itp->nextglob); } /* KWDB_DELETEENTRY -- Delete an entry from the database given its entry * pointer. */ kwdb_DeleteEntry (kwdb, ep) pointer kwdb; int ep; { register KWDB *db = (KWDB *) kwdb; register Item *itp = NULL, *otp; int hashval, i; char *name; if (ep <= 0 || ep > db->tail) return (-1); itp = REF_EP(db,ep); name = db->sbuf + itp->name; /* If the entry is a keyword remove it from the hash table. */ if (itp->name && *name) { hashval = hash (name); i = db->hashtbl[hashval]; if (ep == i) db->hashtbl[hashval] = itp->nexthash; else { otp = REF_EP(db,i); for (i=otp->nexthash; i; otp=REF_EP(db,i), i=otp->nexthash) if (ep == i) { otp->nexthash = itp->nexthash; break; } } } /* Remove the entry from the global list. */ if (db->head == ep) db->head = itp->nextglob; for (i=db->head; i; i = otp->nextglob) { otp = REF_EP(db,i); if (otp->nextglob == ep) { otp->nextglob = itp->nextglob; break; } } if (db->tail == ep) { db->tail = i; db->itemsused--; } db->nitems--; return (0); } /* KWDB_RENAMEENTRY -- Rename an entry given its entry pointer. * Either the old or new name can be nil. Renaming an entry does not change * its position in the list but if there are redefinitions it becomes the * most recent instance. */ kwdb_RenameEntry (kwdb, ep, newname) pointer kwdb; int ep; char *newname; { register KWDB *db = (KWDB *) kwdb; register Item *itp = NULL, *otp; int hashval, i; char *name; if (ep <= 0 || ep > db->tail) return (-1); itp = REF_EP(db,ep); name = db->sbuf + itp->name; /* If the entry is a keyword remove it from the hash table. */ if (itp->name && *name) { hashval = hash (name); i = db->hashtbl[hashval]; if (ep == i) db->hashtbl[hashval] = itp->nexthash; else { otp = REF_EP(db,i); for (i=otp->nexthash; i; otp=REF_EP(db,i), i=otp->nexthash) if (ep == i) { otp->nexthash = itp->nexthash; break; } } } /* Reenter the item in the hash table using the new name. */ if (newname && *newname) { int hashval = hash (newname); if (i = db->hashtbl[hashval]) itp->nexthash = i; db->hashtbl[hashval] = ep; itp->name = addstr (db, newname); } else itp->name = 0; return (0); } /* KWDB_COPYENTRY -- Copy an entry from one database to another. If newname * is not not null it will be the name of the new entry. The input and output * datbases can be the same. */ kwdb_CopyEntry (kwdb, o_kwdb, o_ep, newname) pointer kwdb; pointer o_kwdb; int o_ep; char *newname; { register KWDB *db = (KWDB *) kwdb; register KWDB *o_db = (KWDB *) o_kwdb; register Item *itp = REF_EP(o_db,o_ep); char *name; if (newname && *newname) name = newname; else name = itp->name + o_db->sbuf; return (kwdb_AddEntry (kwdb, name, itp->value + o_db->sbuf, itp->type + o_db->sbuf, itp->comment + o_db->sbuf)); } /* KWDB_GETENTRY -- Get an entry given its entry pointer. A count of the * number of nonempty strings is returned (i.e. zero is returned if the value * is a blank line, 3 for a full keyword with value and comment). */ kwdb_GetEntry (kwdb, ep, keyword, value, type, comment) pointer kwdb; int ep; char **keyword, **value, **type, **comment; { register KWDB *db = (KWDB *) kwdb; register Item *itp; if (ep <= 0 || ep > db->tail) return (-1); else itp = REF_EP(db,ep); if (keyword) *keyword = itp->name + db->sbuf; if (value) *value = itp->value + db->sbuf; if (type) *type = itp->type + db->sbuf; if (comment) *comment = itp->comment + db->sbuf; return (itp->name + itp->value + itp->type, itp->comment); } /* KWDB_KWNAME -- Return a pointer to the name of a keyword given its entry * pointer. */ char * kwdb_KWName (kwdb, ep) pointer kwdb; int ep; { register KWDB *db = (KWDB *) kwdb; register Item *itp; if (ep <= 0 || ep > db->tail) return (NULL); else itp = REF_EP(db,ep); return (itp->name + db->sbuf); } /* * Utility routines. * ------------------- */ /* KWDB_OPENFITS -- Open a FITS file and read the file header into a KWDB * keyword database. Each 80 character card image in the input file * corresponds to one entry in the output KWDB. Values of the type field * generated are L (logical), S (string), N (numeric), H (history), * C (comment), T (text other than history or comment), and B (blank). * Any trailing blank lines at the end of the header are omitted, but a * count of the number of blank trailers can be returned as an argument if * desired. The KWDB pointer is returned as the function value. */ pointer kwdb_OpenFITS (filename, maxcards, nblank) char *filename; /* file to be opened */ int maxcards; /* maximum FITS cards to be read */ int *nblank; /* if not NULL receives count of blank lines at end */ { register KWDB *kwdb; int fd; /* Open FITS file. */ if ((fd = open (filename, O_RDONLY)) < 0) return (NULL); /* Open new, empty KWDB. */ if (!(kwdb = (KWDB *) kwdb_Open (filename))) { close (fd); return (NULL); } /* Scan the file into the KWDB. */ if (kwdb_ReadFITS (kwdb, fd, maxcards, nblank) < 0) { close (fd); return (NULL); } close (fd); return ((pointer) kwdb); } /* KWDB_READFITS -- Scan a file stream and load successive FITS cards into * a keyword database. Each 80 character card image in the input file * corresponds to one entry in the output KWDB. Values of the type field * generated are L (logical), S (string), N (numeric), H (history), * C (comment), T (text other than history or comment), and B (blank). * Any trailing blank lines at the end of the header are omitted, but a * count of the number of blank trailers can be returned as an argument if * desired. A count of the number of cards read is returned as the function * value, or -1 if an error occurs. */ kwdb_ReadFITS (kwdb, fd, maxcards, nblank) pointer kwdb; int fd; int maxcards; int *nblank; { register KWDB *db = (KWDB *) kwdb; register char *ip, *op; char keyword[9], value[80], type[2], comment[80]; int ncards, istext, isstring, iscomment, ishistory, ep, nb, n; char card[80], *lop; for (ncards=0; (!maxcards || ncards < maxcards) && db->read(fd,card,80)==80; ncards++) { istext = isstring = 0; /* Get keyword field (if any). */ for (ip=card, n=8, op=keyword; --n >= 0 && *ip != ' '; ) *op++ = *ip++; *op = '\0'; /* Quit when we see the END card, or if we miss the END card and * run into some binary data. */ for (ip=card, n=8; --n >= 0; ip++) if (!isprint (*ip)) { strcpy (keyword, "END "); break; } if (streq (keyword, "END")) break; iscomment = (streq (keyword, "COMMENT")); ishistory = (streq (keyword, "HISTORY")); /* Get value field if any. */ if (!iscomment && !ishistory && card[8] == '=') { istext = 0; op = value; for (ip=card+9, n=21; --n >= 0 && isspace(*ip); ) ip++; if (*ip == '\'') { ip++; isstring = 1; while (*ip != '\'' && ip < card+80) *op++ = *ip++; ip++; } else { while (*ip != ' ' && *ip != '/' && ip < card+80) *op++ = *ip++; } *op = '\0'; /* Get comment field if any. Trailing whitespace is trimmed. */ while ((*ip == '/' || *ip == ' ') && ip < card+80) ip++; for (op=lop=comment; ip < card+80 && *ip != '\n'; ip++) { *op++ = *ip; if (*ip != ' ') lop = op; } *lop = '\0'; } else { istext = 1; /* Process history or comment (text) card. The text is placed * in the value field. Trailing whitespace is trimmed. */ op = lop = value; for (ip=card+8; ip < card+80 && *ip != '\n'; ip++) { *op++ = *ip; if (*ip != ' ') lop = op; } *lop = '\0'; } /* Determine the card type. */ if (istext) { if (iscomment) strcpy (type, "C"); else if (ishistory) strcpy (type, "H"); else strcpy (type, "T"); } else { if (isstring) strcpy (type, "S"); else if (streq(value,"T") || streq(value,"F")) strcpy (type, "L"); else strcpy (type, "N"); } /* Enter the card into the KWDB. */ if (kwdb_AddEntry(kwdb, keyword, value, type, comment) < 0) { return (-1); } } /* Trim any blank lines at the end of the header list. */ for (ep=kwdb_Tail(kwdb), nb=0; ep > 0; ep=kwdb_Tail(kwdb), nb++) { char *keyword, *value, *type; if (kwdb_GetEntry (kwdb, ep, &keyword, &value, &type, NULL) >= 0) if (*type == 'T' && *value == '\0') kwdb_DeleteEntry (kwdb, ep); else break; } if (nblank) *nblank = nb; return (ncards); } /* KWDB_UPDATEFITS -- Update the contents of a FITS file header from a KWDB * database to a FITS header. If update=0 a new FITS file is written * consisting of only a header (from the KWDB) and no data. If update=1 the * header of an existing file is updated in place, replacing the entire header * with the contents of the KWDB. If extend=1 in update mode, the file will * automatically be extended if the KWDB will not fit in the existing header * area. */ kwdb_UpdateFITS (kwdb, filename, update, extend, npad) register KWDB *kwdb; char *filename; int update, extend, npad; { register char *ip, *op, *cp; int nblocks, nbytes, lastone, maxcards, new, fd, i; char card[256], tmpfile[512]; char block[SZ_FILEBUF]; char *lop; /* Prepare the output file. If we are updating an existing file it * must exist and must have sufficient space to hold the contents of * the KWDB. If we are writing to a new file we must be able to * create the file. */ if (update) { /* Update an existing file. */ if ((fd = open (filename, O_RDWR)) < 0) return (-1); /* Determine the capacity of the file header. */ lastone = 0; maxcards = 0; while (!lastone && read (fd, block, 2880) == 2880) { for (i=0, cp=block; i < 36; i++, cp += 80) { cp[8] = '\0'; if (streq (cp, "END")) { lastone++; break; } } maxcards += (lastone ? 35 : 36); } /* Extend the file if there is insufficient space and extension * is requested. */ if (kwdb_Len(kwdb) > maxcards) { if (!extend) { close (fd); return (-1); } /* Get a scratch file. */ for (ip=filename, op=lop=tmpfile; *ip; ip++) if ((*op++ = *ip) == '/') lop = op; for (ip="kwdb.XXXXXX", op=lop; *op++ = *ip++; ) ; *op = '\0'; if (!mkstemp(tmpfile)) { close (fd); return (-1); } if ((new = open (tmpfile, O_CREAT|O_TRUNC|O_RDWR, 0644)) < 0) { close (fd); return (-1); } /* Write the header area of the new file. */ nblocks = (kwdb_Len(kwdb) + npad + 1) + 35 / 36; memset (block, 0, 2880); while (--nblocks >= 0) if (write (new, block, 2880) != 2880) { abort: close (fd); close (new); unlink (tmpfile); return (-1); } /* Copy the data area of the target file. */ while ((nbytes = read (fd, block, SZ_FILEBUF)) > 0) if (write (new, block, nbytes) != nbytes) goto abort; /* Replace the original file with the extended version. */ if (close (new) < 0) goto abort; if (close (fd) < 0) goto abort; if (rename (tmpfile, filename) < 0) goto abort; /* Ready the newly extended file for header updating. */ if ((fd = open (filename, O_RDWR)) < 0) return (-1); } else lseek (fd, 0L, SEEK_SET); } else { /* Write a new file. */ if ((fd = open (filename, O_CREAT|O_WRONLY, 0644)) < 0) return (-1); } /* Output the KWDB as a FITS file header. */ kwdb_SetIO (kwdb, read, write); if (kwdb_WriteFITS (kwdb, fd) < 0) { close (fd); return (-1); } /* Write the END card to mark the end of the header. */ strcpy (card, "END"); memset (card+3, ' ', 80-3); if (write (fd, card, 80) != 80) { close (fd); return (-1); } return (close (fd)); } /* KWDB_WRITEFITS -- Write the contents of a KWDB database to a file stream. * The KWDB entries are written out one per FITS card without any checks. * No END card is written. WriteFITS may be called to write all or part of * a FITS header. */ kwdb_WriteFITS (kwdb, fd) KWDB *kwdb; int fd; { register KWDB *db = (KWDB *) kwdb; register char *ip, *op, *cp; int ncards=0, ep, n, ch; char card[256]; for (ep=kwdb_Head(kwdb); ep; ep=kwdb_Next(kwdb,ep), ncards++) { char *keyword, *value, *type, *comment; /* Get entry from database. */ if ((kwdb_GetEntry(kwdb,ep,&keyword,&value,&type,&comment)) < 0) return (-1); /* Format the FITS card. */ memset (card, ' ', 80); for (ip=keyword, op=card, n=8; *ip && --n >= 0; ) { ch = *ip++; if (isprint (ch)) *op++ = ch; } switch (*type) { case 'S': case 'N': case 'L': card[8] = '='; op = card + 10; /* Output value field. */ if (*type == 'S') { *op++ = '\''; for (ip=value; *ip && op < card+80; ) { ch = *ip++; if (isprint (ch)) *op++ = ch; } while (op < card+19) op++; *op++ = '\''; while (op < card+30) op++; } else { if ((n = 20 - strlen(value)) > 0) op += n; for (ip=value; *ip && op < card+80; ) { ch = *ip++; if (isprint (ch)) *op++ = ch; } } /* Output comment. */ if (*comment && op < card+80) { op++; *op++ = '/'; op++; for (ip=comment; *ip && op < card+80; ) { ch = *ip++; if (isprint (ch)) *op++ = ch; } } break; default: for (ip=value, op=card+8; *ip && op < card+80; ) *op++ = *ip++; break; } /* Write card to the output file. */ if (db->write (fd, card, 80) != 80) return (-1); } return (ncards); } /* KWDB_SETIO -- Set the read and write functions to be used by kwdb_ReadFITS * and kwdb_WriteFITS. */ kwdb_SetIO (kwdb, readfcn, writefcn) register KWDB *kwdb; int (*readfcn)(); int (*writefcn)(); { register KWDB *db = (KWDB *) kwdb; db->read = readfcn; db->write = writefcn; } /* * Internal functions. * ------------------- */ /* ADDSTR -- Add a string to the database string buffer. The sbuf index of * the string is returned. If the string is NULL or empty zero is returned. * Element zero of sbuf is always the null/empty string. */ static int addstr (db, text) register KWDB *db; char *text; { int offset, sbuflen, nchars; char *sbuf; if (!text || !*text) return (0); nchars = strlen(text) + 1; /* Get more space if the string buffer fills. */ if (db->sbufused + nchars >= db->sbuflen) { sbuflen = db->sbuflen + DEF_SZSBUF; if (!(sbuf = (char *) realloc (db->sbuf, sbuflen))) return (0); db->sbuf = sbuf; db->sbuflen = sbuflen; } strcpy (db->sbuf + db->sbufused, text); offset = db->sbufused; db->sbufused += nchars; return (offset); } /* HASH -- Compute the (case insensitive) hash value of a string. */ static int hash (key) char *key; { register char *ip; register int sum, i, ch; for (ip=key, sum=i=0; (ch = *ip) && i < MAX_HASHCHARS; i++) sum += (isupper(ch) ? tolower(ch) : ch) * primes[i]; return (sum % NTHREADS); } /* STREQ -- Case insensitive string compare. */ static int streq (s1, s2) register char *s1, *s2; { register int c1, c2; for (;;) { c1 = *s1++; c2 = *s2++; if (!c1 || !c2) break; if (isupper(c1)) c1 = tolower(c1); if (isupper(c2)) c2 = tolower(c2); if (c1 != c2) break; } return (!c1 && !c2); } fitsutil-2018.07.06/src/kwdb.h000066400000000000000000000021731332007674300156610ustar00rootroot00000000000000/* * KWDB.H -- KWDB global definitions. */ typedef void *pointer; int kwdb_AddEntry (/* kwdb, keyword, value, type, comment */); void kwdb_Close (/* kwdb) */); int kwdb_CopyEntry (/* kwdb, o_kwdb, o_ep) */); int kwdb_DeleteEntry (/* kwdb, ep) */); char *kwdb_GetComment (/* kwdb, keyword) */); int kwdb_GetEntry (/* kwdb, ep, keyword, value, type, comment */); char *kwdb_GetType (/* kwdb, keyword) */); char *kwdb_GetValue (/* kwdb, keyword) */); int kwdb_Head (/* kwdb) */); int kwdb_Len (/* kwdb) */); int kwdb_Lookup (/* kwdb, keyword) */); char *kwdb_Name (/* kwdb) */); char *kwdb_KWName (/* kwdb, ep) */); int kwdb_Next (/* kwdb, ep */); pointer kwdb_Open (/* kwdbname */); int kwdb_SetComment (/* kwdb, keyword, comment */); int kwdb_SetType (/* kwdb, keyword, type */); int kwdb_SetValue (/* kwdb, keyword, value */); int kwdb_Tail (/* kwdb */); pointer kwdb_OpenFITS (/* filename, maxcards, nblank */); int kwdb_UpdateFITS (/* kwdb, filename, update, extend, npad */); int kwdb_ReadFITS (/* kwdb, fd, maxcards, nblank */); int kwdb_WriteFITS (/* kwdb, fd */); /* Compatibility garbage. */ #ifndef SEEK_SET #define SEEK_SET 0 #endif fitsutil-2018.07.06/src/mkpkg000066400000000000000000000032111332007674300156070ustar00rootroot00000000000000# Make the FITSUTIL package $call relink $call install $exit update: $call relink $call install ; relink: $update libpkg.a $omake x_fxutil.x # $link x_fxutil.o libpkg.a -lmef -ldbc -lxtools -o xx_fitsutil.e # $link x_fxutil.o libpkg.a -lmef -lxtools -o xx_fitsutil.e $link x_fxutil.o libpkg.a -lxtools -o xx_fitsutil.e $ifeq (MACH, linux, redhat, macosx, macintel) then !cc -m32 -c $(HSI_CF) fgwrite.c fgread.c sum32.c checksum.c kwdb.c !cc -m32 $(HSI_LF) fgwrite.o kwdb.o -o fgwrite.e !cc -m32 $(HSI_LF) fgread.o kwdb.o checksum.o -o fgread.e !cc -m32 $(HSI_LF) sum32.o checksum.o -o sum32 $else !cc -c $(HSI_CF) fgwrite.c fgread.c sum32.c checksum.c kwdb.c !cc fgwrite.o kwdb.o -o fgwrite.e !cc fgread.o kwdb.o checksum.o -o fgread.e !cc sum32.o checksum.o -o sum32 $endif !rm fgwrite.o fgread.o kwdb.o checksum.o sum32.o ; install: $move xx_fitsutil.e fitsutilbin$x_fitsutil.e $move fgread.e fitsutilbin$fgread.e $move fgwrite.e fitsutilbin$fgwrite.e $move sum32 fitsutilbin$sum32 ; libpkg.a: #$set XFLAGS='-cfgq -p fitsutil' catprhdr.x "dfits.h" "dfits.com" dfits.x "dfits.h" "dfits.com" fxcopy.x fxconvert.x fxdelete.x fxextract.x fxdummyh.x fxheader.x fxsplit.x fxinsert.x fxplf.x \ getcmd.x ; fitsutil-2018.07.06/src/ricepack.cl000066400000000000000000000076541332007674300166730ustar00rootroot00000000000000#{ RICEPACK - Wrapper script for the CFITSIO 'fpack' task procedure ricepack (images) string images {prompt="input images"} bool keep = no {prompt="keep input images?"} bool listonly = no {prompt="only list file contents?"} bool verbose = yes {prompt="verbose messages?"} int quantization = 16 {prompt="q level for floating point scaling"} #string flags = "" {prompt="explicit CFITSIO flags"} int nimages {prompt="number of images compressed"} #bool goahead = no {prompt="continue?"} string *imlist begin string limages, img, outimg, tmpfile, lflags, date1, date2, junk real tstart, tend, hours, seconds, R int count, filsiz, insize, outsize, len, dsize, benefit bool lgo struct tbuf cache sections limages = images if (listonly) { lflags = "-L " # will be concatenated, so needs final blank if (verbose) printf ("list contents, no files created or deleted\n") # } else if (strlen (flags) > 1 && stridx ('-', flags) > 0) { # lflags = flags // " " # # if (keep) { # printf ("warning: flags may override keep=yes, ") # goahead.p_mode="ql"; lgo=goahead; goahead.p_mode="h" # if (!lgo) return # } } else { lflags = "-q " // quantization // " " if (!keep) lflags += "-D " if (verbose) lflags += "-v " } tmpfile = mktemp ("tmp$fpack_") sections (limages, opt="fullname", > tmpfile) if (sections.nimages <= 0) { printf ("no images in input list\n") return } insize = 0 imlist = tmpfile while (fscan (imlist, img) != EOF) { # preflight check if (! access (img)) { printf ("input image %s not found\n", img) return } len = strlen (img) if (substr (img, len-2, len) == ".fz") { printf ("input image %s is already tile compressed\n", img) return } if (substr (img, len-3, len) == ".imh" && !keep) { printf ('compressing IRAF ".imh" images requires keep=yes\n') return } if (substr (img, len-2, len) == ".gz") outimg = substr (img, 1, len-3) // ".fz" else if (substr (img, len-3, len) == ".imh") outimg = substr (img, 1, len-4) // "fits.fz" else outimg = img // ".fz" if (access (outimg)) { printf ("output image %s already exists\n", outimg) return } filsiz = 0 directory (img, long+) | scan (junk, junk, filsiz) insize += int ((real (filsiz) / 1024.) + 0.5) } if (verbose) { t_fpack ("-V") time | scan (tbuf); print (tbuf) | scan (junk, tstart, date1) printf ("\n%s\n", tbuf) } count = 0 outsize = 0 imlist = tmpfile while (fscan (imlist, img) != EOF) { t_fpack (lflags // osfn(img)) len = strlen (img) if (substr (img, len-2, len) == ".gz") { outimg = substr (img, 1, len-3) // ".fz" } else if (substr (img, len-3, len) == ".imh") { outimg = substr (img, 1, len-4) // "fits.fz" if (access (img//".fz")) rename (img//".fz", outimg, field="all") } else outimg = img // ".fz" filsiz = 0 directory (outimg, long+) | scan (junk, junk, filsiz) outsize += int ((real (filsiz) / 1024.) + 0.5) count += 1 } imlist = ""; delete (tmpfile, ver-, >& "dev$null") nimages = count if (verbose && count > 0) { time | scan (tbuf); print (tbuf) | scan (junk, tend, date2) printf ("%s\n\n", tbuf) # midnight handling is a kludge, but errors will be few & harmless hours = tend - tstart; if (date2 != date1) hours += 24.0 seconds = hours * 3600.0 / count printf ("%d images, %4.2f seconds each, %h elapsed\n\n", count, seconds, hours) printf (" input: %11.3f MB\n", real (insize) / 1024.) if (! listonly && insize > 0 && outsize > 0) { printf ("output: %11.3f MB\n", real (outsize) / 1024.) R = real (insize) / real (outsize) dsize = insize - outsize benefit = int (100.0 * abs (1.0 - 1/R) + 0.5) printf (" saved: %11.3f MB, %d%%\n\n", real (dsize) / 1024., benefit) printf ("relative R = %4.2f\n\n", R) } } end fitsutil-2018.07.06/src/sum32.c000066400000000000000000000075511332007674300157030ustar00rootroot00000000000000/* SUM32 -- accumulate the 32 bit and 16 bit 1's complement checksums * for a file. Reports the checksums and their complements as well as * the size of the file. * * Usage: * * sum32 [-v] [-c] [-p] [-i ] [|] * * Command line flags: * -v verbose mode * -c report only the ascii coded complement * -p permute the bytes for FITS keyword alignment * -i invert the transformation given an ascii checksum */ #include #include #include #include #include #include #define SZ_PATHNAME 161 #define RECORD 2880 #define BLOCK 10 #define ERR 0 #define OK 1 main (argc, argv) int argc; char *argv[]; { unsigned short sum16; unsigned int sum32, tmp16; register DIR *dir; int size, len, iarg, i; int verbose=0, code=0, inverse=0, got_name=0, num_mode=0, permute=0; char name[SZ_PATHNAME], ascii[SZ_PATHNAME]; FILE *fp; /* if (argc <= 1) { * print_usage (); * exit (-1); * } */ for (iarg=1; iarg < argc; iarg++) { len = strlen (argv[iarg]); if (argv[iarg][0] == '-' && len == 2) { if (argv[iarg][1] == 'v') { verbose++; continue; } else if (argv[iarg][1] == 'c') { code++; continue; } else if (argv[iarg][1] == 'p') { permute++; continue; } else if (argv[iarg][1] == 'i') { if (++iarg >= argc) { print_usage (); exit (-1); } else { strncpy (ascii, argv[iarg], SZ_PATHNAME); inverse++; continue; } } else { printf ("unknown command line flag `%s'\n", argv[iarg]); print_usage (); exit (-1); } } else if (! got_name) { strncpy (name, argv[iarg], SZ_PATHNAME); got_name++; continue; } else { printf ("too many arguments: `%s'\n", argv[iarg]); print_usage (); exit (-1); } } if (inverse) { sum16 = 0; sum32 = 0; size = strlen (ascii); if (permute) for (i=0; i < size; i++) name[i] = ascii[(i+1)%size] - 0x30; else for (i=0; i < size; i++) name[i] = ascii[i] - 0x30; checksum (name, size, &sum16, &sum32); } else if (! got_name) { size = checkfile (stdin, &sum16, &sum32); } else if ((dir = opendir (name)) != NULL) { /* silently exit if a directory is presented * should likely handle other special files similarly */ closedir (dir); exit (-1); } else if ((fp = fopen (name, "r")) != NULL) { size = checkfile (fp, &sum16, &sum32); fclose (fp); } else { sum32 = atoi (name); tmp16 = sum32 / 0x10000; tmp16 += sum32 % 0x10000; while (tmp16>>16) tmp16 = (tmp16 & 0xFFFF) + (tmp16>>16); sum16 = tmp16; num_mode++; } if (verbose) { char_encode (sum16, ascii, 2, permute); printf ("\nchecksum16: %05u = %8s\n", sum16, ascii); char_encode (~sum16, ascii, 2, permute); printf ("complement: %05u = %8s\n", ~sum16 & 0xFFFF, ascii); char_encode (sum32, ascii, 4, permute); printf ("\nchecksum32: %010u = %16s\n", sum32, ascii); char_encode (~sum32, ascii, 4, permute); printf ("complement: %010u = %16s\n", ~sum32, ascii); if (! num_mode) printf ("\n file size: %d bytes\n\n", size); } else { if (code) { char_encode (~sum32, ascii, 4, permute); printf ("%16s\n", ascii); } else if (~sum32) { printf ("%010u\n", sum32); } else printf ("sum_zeroed\n"); } exit (0); } int checkfile (fp, sum16, sum32) FILE *fp; unsigned short *sum16; unsigned int *sum32; { char record[BLOCK*RECORD]; int size, recsize; *sum16 = 0; *sum32 = 0; size = 0; while (! feof (fp)) if (recsize = fread (record, sizeof(char), BLOCK*RECORD, fp)) { checksum (record, recsize, sum16, sum32); size += recsize; } return (size); } print_usage () { printf ("usage: sum32 [-v] [-c] [-p] [-i ] [|]\n"); } fitsutil-2018.07.06/src/sum32.cl000066400000000000000000000024161332007674300160520ustar00rootroot00000000000000#{ SUM32 - calculate the FITS checksum on a list of files procedure sum32 (input) string input {prompt="input files"} bool verbose = no {prompt="verbose messages?"} int nimages {prompt="number of images checksummed"} string *imlist begin string limages, img, tmpfile, junk, sumstr int count, filsiz, insize cache sections limages = input tmpfile = mktemp ("tmp$sum32_") sections (limages, opt="fullname", > tmpfile) if (sections.nimages <= 0) { printf ("nothing in input list\n") return } imlist = tmpfile while (fscan (imlist, img) != EOF) { # preflight check if (! access (img)) { printf ("input image %s not found\n", img) return } } count = 0 insize = 0 imlist = tmpfile while (fscan (imlist, img) != EOF) { filsiz = 0 directory (img, long+) | scan (junk, junk, filsiz) if (verbose) { t_sum32 ("-v " // osfn(img)) } else { sumstr = "NONE" t_sum32 (osfn(img)) | scan (sumstr) if (sumstr != "NONE") printf ("%10s %10d %s\n", sumstr, filsiz, img) } insize += int ((real (filsiz) / 1024.) + 0.5) count += 1 } imlist = ""; delete (tmpfile, ver-, >& "dev$null") nimages = count if (verbose && count > 0) printf ("%d files, %.3f MB\n", count, real(insize)/1024.) end fitsutil-2018.07.06/src/x_fxutil.x000066400000000000000000000004011332007674300166040ustar00rootroot00000000000000 task fxheader = t_fxheader, fxdummyh = t_fxdummyh, fxextract = t_fxextract, fxcopy = t_fxcopy, fxconvert = t_fxconvert, fxinsert = t_fxinsert, fxsplit = t_fxsplit, fxdelete = t_fxdelete, fxplf = t_fxplf