aboutsummaryrefslogtreecommitdiff
path: root/pkg/dataio/fits/fits_wimage.x
diff options
context:
space:
mode:
Diffstat (limited to 'pkg/dataio/fits/fits_wimage.x')
-rw-r--r--pkg/dataio/fits/fits_wimage.x497
1 files changed, 497 insertions, 0 deletions
diff --git a/pkg/dataio/fits/fits_wimage.x b/pkg/dataio/fits/fits_wimage.x
new file mode 100644
index 00000000..7ed00372
--- /dev/null
+++ b/pkg/dataio/fits/fits_wimage.x
@@ -0,0 +1,497 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include <error.h>
+include <imhdr.h>
+include "wfits.h"
+
+# WFT_WRITE_IMAGE -- Procedure to convert IRAF image data to FITS format line by
+# line.
+
+procedure wft_write_image (im, fits, fits_fd)
+
+pointer im # IRAF image descriptor
+pointer fits # FITS data structure
+int fits_fd # FITS file descriptor
+
+int npix, nlines, npix_record, i, stat, nrecords
+long v[IM_MAXDIM]
+pointer tempbuf, buf
+
+int wft_get_image_line()
+errchk malloc, mfree, wft_get_image_line, wft_lscale_line, wft_long_line
+errchk wft_init_write_pixels, wft_write_pixels, wft_write_last_record
+errchk wft_rscale_line, wft_dscale_line
+
+include "wfits.com"
+
+begin
+ if (NAXIS(im) == 0) {
+ if (short_header == YES || long_header == YES) {
+ call printf ("0 Data logical (2880 byte) records written\n")
+ }
+ return
+ }
+
+ # Initialize.
+ npix = NAXISN(im,1)
+ nlines = 1
+ do i = 2, NAXIS(im)
+ nlines = nlines * NAXISN(im, i)
+ npix_record = len_record * FITS_BYTE / abs (FITS_BITPIX(fits))
+
+ call amovkl (long(1), v, IM_MAXDIM)
+ switch (FITS_BITPIX(fits)) {
+ case FITS_REAL:
+
+ # Allocate temporary space.
+ call malloc (tempbuf, npix, TY_REAL)
+
+ # Initialize the pixel write.
+ call wft_init_write_pixels (npix_record, TY_REAL,
+ FITS_BITPIX(fits), blkfac)
+
+ # For the time being explicitly turn off ieee NaN mapping.
+ call ieemapr (NO, NO)
+
+ # Scale the lines, deal with the blanks via the ieee code which
+ # is currently turned off, and write the output records.
+
+ do i = 1, nlines {
+ iferr (stat = wft_get_image_line (im, buf, v, PIXTYPE(im))) {
+ call erract (EA_WARN)
+ call error (10, "WRT_IMAGE: Error writing IRAF image.")
+ }
+ if (stat == EOF )
+ return
+ if (stat != npix)
+ call error (10, "WRT_IMAGE: Error writing IRAF image.")
+ if (SCALE(fits) == YES)
+ call wft_rscale_line (buf, Memr[tempbuf], npix,
+ 1. / BSCALE(fits), -BZERO(fits), PIXTYPE(im))
+ else
+ call wft_real_line (buf, Memr[tempbuf], npix, PIXTYPE(im))
+ call wft_write_pixels (fits_fd, Memr[tempbuf], npix)
+ }
+
+ # Free space.
+ call mfree (tempbuf, TY_REAL)
+
+ case FITS_DOUBLE:
+
+ # Allocate temporary space.
+ call malloc (tempbuf, npix, TY_DOUBLE)
+
+ # Initialize the pixel write.
+ call wft_init_write_pixels (npix_record, TY_DOUBLE,
+ FITS_BITPIX(fits), blkfac)
+
+ # For the time being explicitly turn off ieee NaN mapping.
+ call ieemapd (NO, NO)
+
+ # Scale the lines, deal with the blanks via the ieee code which
+ # is currently turned off, and write the output records.
+
+ do i = 1, nlines {
+ iferr (stat = wft_get_image_line (im, buf, v, PIXTYPE(im))) {
+ call erract (EA_WARN)
+ call error (10, "WRT_IMAGE: Error writing IRAF image.")
+ }
+ if (stat == EOF )
+ return
+ if (stat != npix)
+ call error (10, "WRT_IMAGE: Error writing IRAF image.")
+ if (SCALE(fits) == YES)
+ call wft_dscale_line (buf, Memd[tempbuf], npix,
+ 1. / BSCALE(fits), -BZERO(fits), PIXTYPE(im))
+ else
+ call wft_double_line (buf, Memd[tempbuf], npix,
+ PIXTYPE(im))
+ call wft_write_pixels (fits_fd, Memd[tempbuf], npix)
+ }
+
+ # Free space.
+ call mfree (tempbuf, TY_DOUBLE)
+
+ default:
+
+ # Allocate temporary space.
+ call malloc (tempbuf, npix, TY_LONG)
+
+ # Scale the line, deal with the blanks, and write the output
+ # record. At the moement blanks are not dealt with.
+
+ call wft_init_write_pixels (npix_record, TY_LONG, FITS_BITPIX(fits),
+ blkfac)
+ do i = 1, nlines {
+ iferr (stat = wft_get_image_line (im, buf, v, PIXTYPE(im))) {
+ call erract (EA_WARN)
+ call error (10, "WRT_IMAGE: Error writing IRAF image.")
+ }
+ if (stat == EOF )
+ return
+ if (stat != npix)
+ call error (10, "WRT_IMAGE: Error writing IRAF image.")
+ if (SCALE(fits) == YES)
+ call wft_lscale_line (buf, Meml[tempbuf], npix,
+ 1. / BSCALE(fits), -BZERO(fits), PIXTYPE(im))
+ else
+ call wft_long_line (buf, Meml[tempbuf], npix, PIXTYPE(im))
+ # call map_blanks (im, Meml[tempbuf], blank)
+ call wft_write_pixels (fits_fd, Meml[tempbuf], npix)
+ }
+ # Free space.
+ call mfree (tempbuf, TY_LONG)
+ }
+
+ # Write the final record.
+ call wft_write_last_record (fits_fd, nrecords)
+ if (short_header == YES || long_header == YES) {
+ call printf ("%d Data logical (2880 byte) records written\n")
+ call pargi (nrecords)
+ }
+end
+
+
+# WFT_GET_IMAGE_LINE -- Procedure to fetch the next image line.
+
+int procedure wft_get_image_line (im, buf, v, datatype)
+
+pointer im # IRAF image descriptor
+pointer buf # pointer to image line
+long v[ARB] # imio dimension descriptor
+int datatype # IRAF image data type
+
+int npix
+int imgnll(), imgnlr(), imgnld(), imgnlx()
+errchk imgnll, imgnlr, imgnld, imgnlx
+
+begin
+ switch (datatype) {
+ case TY_SHORT, TY_INT, TY_USHORT, TY_LONG:
+ npix = imgnll (im, buf, v)
+ case TY_REAL:
+ npix = imgnlr (im, buf, v)
+ case TY_DOUBLE:
+ npix = imgnld (im, buf, v)
+ case TY_COMPLEX:
+ npix = imgnlx (im, buf, v)
+ default:
+ call error (11, "GET_IMAGE_LINE: Unknown IRAF image type.")
+ }
+
+ return (npix)
+end
+
+
+# WFT_RSCALE_LINE -- This procedure converts the IRAF data to type real
+# and scales by the FITS parameters bscale and bzero.
+
+procedure wft_rscale_line (buf, outbuffer, npix, bscale, bzero, datatype)
+
+pointer buf # pointer to IRAF image line
+real outbuffer[ARB] # FITS integer buffer
+int npix # number of pixels
+double bscale, bzero # FITS bscale and bzero parameters
+int datatype # data type of image
+
+errchk achtlr, altadr, amovr, achtdr, acthxr
+
+begin
+ switch (datatype) {
+ case TY_SHORT, TY_INT, TY_LONG, TY_USHORT:
+ call achtlr (Meml[buf], outbuffer, npix)
+ call altadr (outbuffer, outbuffer, npix, bzero, bscale)
+ case TY_REAL:
+ call amovr (Memr[buf], outbuffer, npix)
+ call altadr (outbuffer, outbuffer, npix, bzero, bscale)
+ case TY_DOUBLE:
+ call achtdr (Memd[buf], outbuffer, npix)
+ call altadr (outbuffer, outbuffer, npix, bzero, bscale)
+ case TY_COMPLEX:
+ call achtxr (Memx[buf], outbuffer, npix)
+ call altadr (outbuffer, outbuffer, npix, bzero, bscale)
+ default:
+ call error (12, "WFT_RSCALE_LINE: Unknown IRAF image type.")
+ }
+end
+
+
+# WFT_DSCALE_LINE -- This procedure converts the IRAF data to type double with
+# after scaling by the FITS parameters bscale and bzero.
+
+procedure wft_dscale_line (buf, outbuffer, npix, bscale, bzero, datatype)
+
+pointer buf # pointer to IRAF image line
+double outbuffer[ARB] # FITS integer buffer
+int npix # number of pixels
+double bscale, bzero # FITS bscale and bzero parameters
+int datatype # data type of image
+
+errchk achtld, altad, amovd, achtrd, achtxd
+
+begin
+ switch (datatype) {
+ case TY_SHORT, TY_INT, TY_LONG, TY_USHORT:
+ call achtld (Meml[buf], outbuffer, npix)
+ call altad (outbuffer, outbuffer, npix, bzero, bscale)
+ case TY_REAL:
+ call achtrd (Memr[buf], outbuffer, npix)
+ call altad (outbuffer, outbuffer, npix, bzero, bscale)
+ case TY_DOUBLE:
+ call amovd (Memd[buf], outbuffer, npix)
+ call altad (outbuffer, outbuffer, npix, bzero, bscale)
+ case TY_COMPLEX:
+ call achtxd (Memx[buf], outbuffer, npix)
+ call altad (outbuffer, outbuffer, npix, bzero, bscale)
+ default:
+ call error (12, "WFT_DSCALE_LINE: Unknown IRAF image type.")
+ }
+end
+
+
+# WFT_LSCALE_LINE -- This procedure converts the IRAF data to type long with
+# after scaling by the FITS parameters bscale and bzero.
+
+procedure wft_lscale_line (buf, outbuffer, npix, bscale, bzero, datatype)
+
+pointer buf # pointer to IRAF image line
+long outbuffer[ARB] # FITS integer buffer
+int npix # number of pixels
+double bscale, bzero # FITS bscale and bzero parameters
+int datatype # data type of image
+
+errchk altall, altarl, altadl, altaxl
+
+begin
+ switch (datatype) {
+ case TY_SHORT, TY_INT, TY_LONG, TY_USHORT:
+ call altall (Meml[buf], outbuffer, npix, bzero, bscale)
+ case TY_REAL:
+ call altarl (Memr[buf], outbuffer, npix, bzero, bscale)
+ case TY_DOUBLE:
+ call altadl (Memd[buf], outbuffer, npix, bzero, bscale)
+ case TY_COMPLEX:
+ call altaxl (Memx[buf], outbuffer, npix, bzero, bscale)
+ default:
+ call error (12, "WFT_LSCALE_LINE: Unknown IRAF image type.")
+ }
+end
+
+
+# WFT_REAL_LINE -- This procedure converts the IRAF image line to type long with
+# no scaling.
+
+procedure wft_real_line (buf, outbuffer, npix, datatype)
+
+pointer buf # pointer to IRAF image line
+real outbuffer[ARB] # buffer of FITS integers
+int npix # number of pixels
+int datatype # IRAF image datatype
+
+errchk achtlr, achtdr, amovr, achtxr
+
+begin
+ switch (datatype) {
+ case TY_SHORT, TY_INT, TY_LONG, TY_USHORT:
+ call achtlr (Meml[buf], outbuffer, npix)
+ case TY_REAL:
+ call amovr (Memr[buf], outbuffer, npix)
+ case TY_DOUBLE:
+ call achtdr (Memd[buf], outbuffer, npix)
+ case TY_COMPLEX:
+ call achtxr (Memx[buf], outbuffer, npix)
+ default:
+ call error (13, "WFT_REAL_LINE: Unknown IRAF data type.")
+ }
+end
+
+
+# WFT_DOUBLE_LINE -- This procedure converts the IRAF image line to type long
+# with no scaling.
+
+procedure wft_double_line (buf, outbuffer, npix, datatype)
+
+pointer buf # pointer to IRAF image line
+double outbuffer[ARB] # buffer of FITS integers
+int npix # number of pixels
+int datatype # IRAF image datatype
+
+errchk achtld, achtrd, amovd, achtxd
+
+begin
+ switch (datatype) {
+ case TY_SHORT, TY_INT, TY_LONG, TY_USHORT:
+ call achtld (Meml[buf], outbuffer, npix)
+ case TY_REAL:
+ call achtrd (Memr[buf], outbuffer, npix)
+ case TY_DOUBLE:
+ call amovd (Memd[buf], outbuffer, npix)
+ case TY_COMPLEX:
+ call achtxd (Memx[buf], outbuffer, npix)
+ default:
+ call error (13, "WFT_DOUBLE_LINE: Unknown IRAF data type.")
+ }
+end
+
+
+# WFT_LONG_LINE -- This procedure converts the IRAF image line to type long with
+# no scaling.
+
+procedure wft_long_line (buf, outbuffer, npix, datatype)
+
+pointer buf # pointer to IRAF image line
+long outbuffer[ARB] # buffer of FITS integers
+int npix # number of pixels
+int datatype # IRAF image datatype
+
+errchk amovl, achtrl, achtdl, achtxl
+
+begin
+ switch (datatype) {
+ case TY_SHORT, TY_INT, TY_LONG, TY_USHORT:
+ call amovl (Meml[buf], outbuffer, npix)
+ case TY_REAL:
+ call achtrl (Memr[buf], outbuffer, npix)
+ case TY_DOUBLE:
+ call achtdl (Memd[buf], outbuffer, npix)
+ case TY_COMPLEX:
+ call achtxl (Memx[buf], outbuffer, npix)
+ default:
+ call error (13, "WFT_LONG_LINE: Unknown IRAF data type.")
+ }
+end
+
+
+# ALTALL -- Procedure to linearly scale a long vector into a long vector
+# using double precision constants to preserve precision.
+
+procedure altall (a, b, npix, k1, k2)
+
+long a[ARB] # input vector
+long b[ARB] # output vector
+int npix # number of pixels
+double k1, k2 # scaling factors
+
+double dtemp
+int i
+
+begin
+ do i = 1, npix {
+ dtemp = (a[i] + k1) * k2
+ if (dtemp >= 0.0d0)
+ dtemp = dtemp + 0.5d0
+ else
+ dtemp = dtemp - 0.5d0
+ b[i] = dtemp
+ }
+end
+
+
+# ALTARL -- Procedure to linearly scale a real vector into a long vector
+# using double precision constants to preserve precision.
+
+procedure altarl (a, b, npix, k1, k2)
+
+real a[ARB] # input vector
+long b[ARB] # output vector
+int npix # number of pixels
+double k1, k2 # scaling factors
+
+int i
+double dtemp
+
+begin
+ do i = 1, npix {
+ dtemp = (a[i] + k1) * k2
+ if (dtemp >= 0.0d0)
+ dtemp = dtemp + 0.5d0
+ else
+ dtemp = dtemp - 0.5d0
+ b[i] = dtemp
+ }
+end
+
+
+# ALTADL -- Procedure to linearly scale a double vector into a long vector
+# using double precision constants to preserve precision.
+
+procedure altadl (a, b, npix, k1, k2)
+
+double a[ARB] # input vector
+long b[ARB] # output vector
+int npix # number of pixels
+double k1, k2 # scaling factors
+
+int i
+double dtemp
+
+begin
+ do i = 1, npix {
+ dtemp = (a[i] + k1) * k2
+ if (dtemp >= 0.0d0)
+ dtemp = dtemp + 0.5d0
+ else
+ dtemp = dtemp - 0.5d0
+ b[i] = dtemp
+ }
+end
+
+
+# ALTAXL -- Procedure to linearly scale a complex vector into a long vector
+# using double precision constants to preserve precision.
+
+procedure altaxl (a, b, npix, k1, k2)
+
+complex a[ARB] # input vector
+long b[ARB] # output vector
+int npix # number of pixels
+double k1, k2 # scaling factors
+
+int i
+double dtemp
+
+begin
+ do i = 1, npix {
+ dtemp = (a[i] + k1) * k2
+ if (dtemp >= 0.0d0)
+ dtemp = dtemp + 0.5d0
+ else
+ dtemp = dtemp - 0.5d0
+ b[i] = dtemp
+ }
+end
+
+
+# ALTADR -- Procedure to linearly scale a real vector in double precision
+
+procedure altadr (a, b, npix, k1, k2)
+
+real a[ARB] # input vector
+real b[ARB] # output vector
+int npix # number of pixels
+double k1, k2 # scaling factors
+
+int i
+
+begin
+ do i = 1, npix
+ b[i] = (a[i] + k1) * k2
+end
+
+
+# ALTADX -- Procedure to linearly scale a complex vector in double precision
+
+procedure altadx (a, b, npix, k1, k2)
+
+complex a[ARB] # input vector
+complex b[ARB] # output vector
+int npix # number of pixels
+double k1, k2 # scaling factors
+
+int i
+
+begin
+ do i = 1, npix
+ b[i] = (a[i] + k1) * k2
+end
+
generated by cgit (git 2.34.1) at 2025-09-20 05:22:00 -0400