diff options
Diffstat (limited to 'sys/imfort/imcrex.x')
| -rw-r--r-- | sys/imfort/imcrex.x | 170 |
1 files changed, 170 insertions, 0 deletions
diff --git a/sys/imfort/imcrex.x b/sys/imfort/imcrex.x new file mode 100644 index 00000000..5a5bce1e --- /dev/null +++ b/sys/imfort/imcrex.x @@ -0,0 +1,170 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> +include <imhdr.h> +include <fio.h> +include "imfort.h" +include "oif.h" + +# IMCREX -- Create a new image of the indicated size and pixel type. +# Both the header and pixel file are created at the same time. For +# simplicity we put both files in the same directory. The name of the +# pixel file is the same as that of the header file, but with the +# extension ".pix". + +procedure imcrex (image, axlen, naxis, pixtype, ier) + +char image[ARB] #I HOST filename of image +int axlen[IM_MAXDIM] #I axis lengths +int naxis #I number of axes +int pixtype #I pixel type +int ier #O receives error status + +int fp, status, ip, i +long pfsize, clktime, cputime +pointer sp, hdrfile, pixfile, osfn, root, extn, sval, im + +pointer bfopnx() +int imwrhdr(), ctoi() +define done_ 91 +define operr_ 92 +errchk calloc + +begin + call smark (sp) + call salloc (hdrfile, SZ_FNAME, TY_CHAR) + call salloc (pixfile, SZ_PATHNAME, TY_CHAR) + call salloc (osfn, SZ_PATHNAME, TY_CHAR) + call salloc (root, SZ_FNAME, TY_CHAR) + call salloc (extn, SZ_FNAME, TY_CHAR) + call salloc (sval, SZ_FNAME, TY_CHAR) + + # Verify image size and datatype operands. + ier = OK + if (naxis < 1 || naxis > MAX_NAXIS) + ier = IE_NAXIS + if (ier == OK) + do i = 1, naxis + if (axlen[i] < 1) + ier = IE_AXLEN + if (ier == OK) + if (pixtype != TY_SHORT && pixtype != TY_REAL) + ier = IE_PIXTYPE + if (ier != OK) { + call im_seterrop (ier, image) + goto done_ + } + + # Construct the name of the image header file. + call imf_parse (image, Memc[root], Memc[extn]) + if (Memc[extn] == EOS) + call strcpy (OIF_HDREXTN, Memc[extn], SZ_FNAME) + + call strcpy (Memc[root], Memc[hdrfile], SZ_FNAME) + call strcat (".", Memc[hdrfile], SZ_FNAME) + call strcat (Memc[extn], Memc[hdrfile], SZ_FNAME) + + # Check to see if the new image would overwrite an existing one. + # This is an error, unless "clobber" is defined in the user + # environment. + + call strpak (Memc[hdrfile], Memc[osfn], SZ_PATHNAME) + call zfacss (Memc[osfn], 0, 0, status) + if (status == YES) { + call strpak ("clobber", Memc[sval], SZ_FNAME) + call zgtenv (Memc[sval], Memc[sval], SZ_FNAME, status) + if (status != ERR) { + call imdelx (image, ier) + if (ier != OK) { + ier = IE_CREHDR + goto operr_ + } + } else { + ier = IE_CLOBBER + goto operr_ + } + } + + # Create the new image. + fp = bfopnx (Memc[hdrfile], NF, RANDOM) + if (fp == ERR) { + ier = IE_CREHDR +operr_ call sfree (sp) + call im_seterrop (ier, Memc[hdrfile]) + return + } + + # Allocate and initialize the image header. + call calloc (im, LEN_IMDES + LEN_IMHDR, TY_STRUCT) + call zgtime (clktime, cputime) + + call strcpy ("imhdr", IM_MAGIC(im), SZ_IMMAGIC) + call amovi (axlen, IM_LEN(im,1), naxis) + IM_ACMODE(im) = NEW_IMAGE + IM_NDIM(im) = naxis + IM_PIXTYPE(im) = pixtype + IM_HDRLEN(im) = LEN_IMHDR + IM_CTIME(im) = clktime + IM_MTIME(im) = clktime + Memc[IM_USERAREA(im)] = EOS + call imf_initoffsets (im, SZ_DEVBLK) + pfsize = IM_HGMOFF(im) - 1 + + # Get the image format version for new images. + call strpak (ENV_OIFVER, Memc[sval], SZ_FNAME) + call zgtenv (Memc[sval], Memc[sval], SZ_FNAME, status) + if (status != ERR) { + ip = 1 + call strupk (Memc[sval], Memc[sval], SZ_FNAME) + if (ctoi (Memc[sval], ip, IM_HDRVER(im)) <= 0) + IM_HDRVER(im) = DEF_VERSION + } else + IM_HDRVER(im) = DEF_VERSION + + # Get a unique pixel file name. + call aclrc (IM_HDRFILE(im), SZ_IMHDRFILE) + call strcpy (Memc[hdrfile], IM_HDRFILE(im), SZ_IMHDRFILE) + call imf_mkpixfname (im, Memc[pixfile], SZ_IMPIXFILE, ier) + if (ier != OK) + goto done_ + + # Write the image header and close the header file. + if (imwrhdr (fp, im, TY_IMHDR) == ERR) { + call bfclos (fp, status) + status = ERR + } else + call bfclos (fp, status) + + if (status == ERR) { + ier = IE_WRHDR + call im_seterrop (ier, Memc[hdrfile]) + return + } + + # Create the pixel storage file. + call bfalcx (Memc[pixfile], pfsize, status) + if (status == ERR) { + ier = IE_ALCPIX + call im_seterrop (ier, Memc[pixfile]) + goto done_ + } + + # Write the backpointing pixel header into the pixel file. + fp = bfopnx (Memc[pixfile], WO, RANDOM) + if (fp == ERR) { + status = ERR + } else if (imwrhdr (fp, im, TY_PIXHDR) == ERR) { + call bfclos (fp, status) + status = ERR + } else + call bfclos (fp, status) + + call mfree (im, TY_STRUCT) + if (status == ERR) { + ier = IE_ACCPIX + call im_seterrop (ier, Memc[pixfile]) + } else + ier = OK +done_ + call sfree (sp) +end |