Initial commit

1 files changed, 253 insertions, 0 deletions

diff --git a/pkg/dataio/fits/t_wfits.x b/pkg/dataio/fits/t_wfits.x
new file mode 100644
index 00000000..256b9cde
--- /dev/null
+++ b/pkg/dataio/fits/t_wfits.x
@@ -0,0 +1,253 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include <mach.h>
+include <error.h>
+include <fset.h>
+include "wfits.h"
+
+# T_WFITS -- This procedure converts a series of IRAF image files to
+# FITS image files.
+
+procedure t_wfits ()
+
+char	iraf_files[SZ_FNAME]	# list of IRAF images
+char	fits_files[SZ_FNAME]	# list of FITS files
+bool	newtape			# new or used tape ?
+char	in_fname[SZ_FNAME]	# input file name
+char	out_fname[SZ_FNAME]	# output file name
+char	fextn[SZ_FNAME]		# the fits extension
+
+char	ch
+int	imlist, flist, nimages, nfiles, file_number, addext, index
+bool	clgetb(), streq()
+double	clgetd()
+int	imtopen(), imtlen (), wft_get_bitpix(), clgeti(), imtgetim()
+int	mtfile(), btoi(), fstati(), fntlenb(), fntgfnb(), mtneedfileno()
+int	wft_blkfac(), fntrfnb(), strlen(), strldx()
+pointer	fntopnb()
+
+include "wfits.com"
+
+begin
+	# Flush on a newline if STDOUT has not been redirected.
+	if (fstati (STDOUT, F_REDIR) == NO)
+	    call fseti (STDOUT, F_FLUSHNL, YES)
+
+	# Open iraf_files template and determine number of files in list.
+	call clgstr ("iraf_files", iraf_files, SZ_FNAME)
+	imlist = imtopen (iraf_files)
+	nimages = imtlen (imlist)
+
+	# Get the wfits parameters.
+	if (nimages == 1)
+	    wextensions = NO
+	else
+	    wextensions = btoi (clgetb ("extensions"))
+	if (wextensions == NO)
+	    gheader = NO
+	else
+	    gheader = btoi (clgetb ("global_hdr"))
+	long_header = btoi (clgetb ("long_header"))
+	short_header = btoi (clgetb ("short_header"))
+	make_image = btoi (clgetb ("make_image"))
+
+	# Get the FITS bits per pixel and the FITS logical record size.
+	bitpix = wft_get_bitpix (clgeti ("bitpix"))
+	len_record = FITS_RECORD
+
+	# Get the scaling parameters.
+	scale = btoi (clgetb ("scale"))
+	if (scale == YES) {
+	    if (clgetb ("autoscale"))
+		autoscale = YES
+	    else {
+	        bscale = clgetd ("bscale")
+	        bzero = clgetd ("bzero")
+		autoscale = NO
+	    }
+	} else {
+	    autoscale = NO
+	    bscale = 1.0d0
+	    bzero = 0.0d0
+	}
+
+	# Get the output file name and type (tape or disk). If no tape file
+	# number is given for output, the user is asked if the tape is blank
+	# or contains data. If the tape is blank output begins at BOT,
+	# otherwise at EOT.
+
+	call clgstr ("fextn", fextn, SZ_FNAME)
+	ch = '.'
+	if (make_image == YES) {
+	    call clgstr ("fits_files", fits_files, SZ_FNAME)
+	    if (mtfile (fits_files) == YES) {
+		flist = NULL
+		if (mtneedfileno (fits_files) == YES) {
+	            newtape = clgetb ("newtape")
+		    if (newtape)
+			call mtfname (fits_files, 1, out_fname, SZ_FNAME)
+		    else
+			call mtfname (fits_files, EOT, out_fname, SZ_FNAME)
+	        } else {
+		    call strcpy (fits_files, out_fname, SZ_FNAME)
+		    newtape = false
+		}
+	    } else {
+		flist = fntopnb (fits_files, NO)
+		nfiles = fntlenb (flist)
+		if (wextensions == YES && nfiles > 1)
+		    call error (0,
+			"Only one output FITS extensions file can be written")
+		if ((nfiles > 1) && (nfiles != nimages))
+		    call error (0,
+		    "T_WFITS: Input and output lists are not the same length")
+	    }
+	} else {
+	    fits_files[1] = EOS
+	    flist = NULL
+	}
+
+	# Get the fits file blocking factor.
+	blkfac = wft_blkfac (fits_files, clgeti ("blocking_factor"))
+
+	# Loop through the list of input images files.
+
+	file_number = 1
+	while (imtgetim (imlist, in_fname, SZ_FNAME) != EOF) {
+
+	    # Get the output file name. If single file output to disk, use
+	    # name fits_file. If multiple file output to disk, the file number
+	    # is added to the output file name, if no output name list is
+	    # supplied. If an output name list is supplied then the names
+	    # are extracted one by one from that list.
+
+	    if (make_image == YES) {
+	        if (mtfile (fits_files) == YES) {
+		    if (wextensions == NO && file_number == 2)
+			call mtfname (out_fname, EOT, out_fname, SZ_FNAME)
+	        } else if (nfiles > 1) {
+		    if (fntgfnb (flist, out_fname, SZ_FNAME) == EOF)
+			 call error (0, "Error reading output file name")
+		    if (fextn[1] != EOS) {
+			addext = OK
+			index = strldx (ch, out_fname)
+			if (index > 0) {
+			    if (streq (fextn, out_fname[index+1]))
+				addext = ERR
+			    else
+				addext = OK
+			}
+			if (addext == OK){
+		            call strcat (".", out_fname, SZ_FNAME)
+		            call strcat (fextn, out_fname, SZ_FNAME)
+			}
+		    }
+		} else {
+		    if (fntrfnb (flist, 1, out_fname, SZ_FNAME) == EOF)
+		        call strcpy (fits_files, out_fname, SZ_FNAME)
+		    if (nimages > 1 && wextensions == NO) {
+		        call sprintf (out_fname[strlen(out_fname)+1], SZ_FNAME,
+			    "%04d")
+			    call pargi (file_number)
+		    }
+		    if (fextn[1] != EOS) {
+			addext = OK
+			index = strldx (ch, out_fname)
+			if (index > 0) {
+			    if (streq (fextn, out_fname[index+1]))
+				addext = ERR
+			    else
+				addext = OK
+			}
+			if (addext == OK){
+		            call strcat (".", out_fname, SZ_FNAME)
+		            call strcat (fextn, out_fname, SZ_FNAME)
+			}
+		    }
+	        }
+	    }
+
+	    # Write each output file.
+	    iferr (call wft_write_fitz (in_fname, out_fname, file_number,
+		nimages)) {
+		call printf ("Error writing file: %s\n")
+		    call pargstr (out_fname)
+		call erract (EA_WARN)
+		break
+	    } else
+		file_number = file_number + 1
+	}
+
+	# Close up the input and output lists.
+	call clpcls (imlist)
+	if (flist != NULL)
+	    call fntclsb (flist)
+end
+
+
+# WFT_GET_BITPIX -- This procedure fetches the user determined bitpix or ERR if
+# the bitpix is not one of the permitted FITS types.
+
+int procedure wft_get_bitpix (bitpix)
+
+int	bitpix
+
+begin
+	switch (bitpix) {
+	case FITS_BYTE, FITS_SHORT, FITS_LONG, FITS_REAL, FITS_DOUBLE:
+	    return (bitpix)
+	default:
+	    return (ERR)
+	}
+end
+
+
+# WFT_BLKFAC -- Get the fits tape blocking factor.
+
+int procedure wft_blkfac (file, ublkfac)
+
+char	file[ARB]		# the input file name
+int	ublkfac			# the user supplied blocking factor
+
+int	bs, fb, blkfac
+pointer	gty
+int	mtfile(), mtcap(), gtygeti()
+errchk	mtcap(), gtygeti()
+
+begin
+	# Return a blocking factor of 1 if the file is a disk file.
+	if (mtfile (file) == NO)
+	    return (0)
+
+	# Open the tapecap device entry for the given device, and get
+	# the device block size and default FITS blocking factor
+	# parameters.
+
+	iferr (gty = mtcap (file))
+	    return (max (ublkfac,1))
+	iferr (bs = gtygeti (gty, "bs")) {
+	    call gtyclose (gty)
+	    return (max (ublkfac,1))
+	}
+	iferr (fb = max (gtygeti (gty, "fb"), 1))
+	    fb = 1
+
+	# Determine whether the device is a fixed or variable blocked
+	# device. Set the fits blocking factor to the value of the fb
+	# parameter if device is fixed block or if the user has
+	# requested the default blocking factor. Set the blocking factor
+	# to the user requested value if the device supports variable
+	# blocking factors.
+
+	if (bs == 0) {
+	    if (ublkfac <= 0)
+	        blkfac = fb
+	    else
+		blkfac = ublkfac
+	} else
+	    blkfac = fb
+
+	call gtyclose (gty)
+
+	return (blkfac)
+end