diff options
Diffstat (limited to 'vendor/x11iraf/ximtool/clients.old/lib')
53 files changed, 10943 insertions, 0 deletions
diff --git a/vendor/x11iraf/ximtool/clients.old/lib/README b/vendor/x11iraf/ximtool/clients.old/lib/README new file mode 100644 index 00000000..e69de29b --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/README diff --git a/vendor/x11iraf/ximtool/clients.old/lib/dspmmap.f b/vendor/x11iraf/ximtool/clients.old/lib/dspmmap.f new file mode 100644 index 00000000..3542286f --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/dspmmap.f @@ -0,0 +1,356 @@ + integer function dspmmp (pmname, refim) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer refim + integer*2 pmname(*) + integer im + integer*2 fname(255 +1) + integer nowhie + integer errcoe + logical streq + integer impmmp + integer dspmip + logical xerpop + logical xerflg + common /xercom/ xerflg + integer sw0001 + integer*2 st0001(6) + integer*2 st0002(4) + integer*2 st0003(4) + save + data st0001 / 69, 77, 80, 84, 89, 0/ + data st0002 / 66, 80, 77, 0/ + data st0003 / 66, 80, 77, 0/ + if (.not.(nowhie (pmname, fname, 255 ) .eq. 0)) goto 110 + dspmmp = (0) + goto 100 +110 continue + if (.not.(streq (fname, st0001))) goto 120 + dspmmp = (0) + goto 100 +120 continue + if (.not.(fname(1) .eq. 33)) goto 130 + call xerpsh + call imgstr (refim, fname(2), fname, 255 ) + if (.not.xerpop()) goto 140 + fname(1) = 0 +140 continue + goto 131 +130 continue + if (.not.(streq (fname, st0002))) goto 150 + call xerpsh + call imgstr (refim, st0003, fname, 255 ) + if (.not.xerpop()) goto 160 + dspmmp = (0) + goto 100 +160 continue +150 continue +131 continue + call xerpsh + im = impmmp (fname, 1 , 0) + if (.not.xerpop()) goto 170 + sw0001=(errcoe()) + goto 180 +190 continue + im = dspmip (fname, refim) + if (xerflg) goto 100 + goto 181 +200 continue + call erract (2 ) + if (xerflg) goto 100 + goto 181 +180 continue + if (sw0001.eq.743) goto 190 + if (sw0001.eq.921) goto 190 + goto 200 +181 continue +170 continue + call xerpsh + call dsmath (im, refim) + if (.not.xerpop()) goto 210 + call erract (3 ) + if (xerflg) goto 100 +210 continue + dspmmp = (im) + goto 100 +100 return + end + integer function dspmip (pmname, refim) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer refim + integer*2 pmname(*) + integer i + integer ndim + integer npix + integer val + integer sp + integer v1 + integer v2 + integer imin + integer imout + integer pm + integer mw + integer data + integer imgnli + integer immap + integer pmnewk + integer impmmo + integer imgl1i + integer mwopem + logical xerflg + common /xercom/ xerflg + save + call smark (sp) + call salloc (v1, 7 , 5) + call salloc (v2, 7 , 5) + call amovkl (int(1), meml(v1), 7 ) + call amovkl (int(1), meml(v2), 7 ) + imin = immap (pmname, 1 , 0) + if (xerflg) goto 100 + pm = pmnewk (imin, 27) + ndim = memi(imin+200 +7) + npix = meml(imin+200 +1+8-1) +110 if (.not.(imgnli (imin, data, meml(v1)) .ne. -2)) goto 111 + do 120 i = 0, npix-1 + val = memi(data+i) + if (.not.(val .lt. 0)) goto 130 + memi(data+i) = 0 +130 continue +120 continue +121 continue + call pmplpi (pm, meml(v2), memi(data), 0, npix, 12 ) + call amovl (meml(v1), meml(v2), ndim) + goto 110 +111 continue + imout = impmmo (pm, imin) + data = imgl1i (imout) + mw = mwopem (imin) + if (xerflg) goto 100 + call mwsavm (mw, imout) + call mwcloe (mw) + call imunmp (imin) + call sfree (sp) + dspmip = (imout) + goto 100 +100 return + end + subroutine dsmath (im, refim) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer im + integer refim + integer i + integer j + integer k + integer l + integer i1 + integer i2 + integer j1 + integer j2 + integer nc + integer nl + integer ncpm + integer nlpm + integer nx + integer val + double precision x1 + double precision x2 + double precision y1 + double precision y2 + double precision lt(6) + double precision lt1(6) + double precision lt2(6) + integer*4 vold(7 ) + integer*4 vnew(7 ) + integer pm + integer pmnew + integer imnew + integer mw + integer ctx + integer cty + integer bufref + integer bufpm + integer imstai + integer plopen + integer mwopem + integer impmmo + integer imgl1i + integer mwsctn + logical pmempy + logical pmliny + logical xerflg + common /xercom/ xerflg + integer*2 st0001(40) + integer*2 st0002(8) + integer*2 st0003(9) + integer*2 st0004(8) + integer*2 st0005(9) + save + integer iyy + data (st0001(iyy),iyy= 1, 8) / 73,109, 97,103,101, 32, 97,110/ + data (st0001(iyy),iyy= 9,16) /100, 32,109, 97,115,107, 32,104/ + data (st0001(iyy),iyy=17,24) / 97,118,101, 32, 97, 32,114,101/ + data (st0001(iyy),iyy=25,32) /108, 97,116,105,118,101, 32,114/ + data (st0001(iyy),iyy=33,40) /111,116, 97,116,105,111,110, 0/ + data st0002 /108,111,103,105, 99, 97,108, 0/ + data (st0003(iyy),iyy= 1, 8) /112,104,121,115,105, 99, 97,108/ + data (st0003(iyy),iyy= 9, 9) / 0/ + data st0004 /108,111,103,105, 99, 97,108, 0/ + data (st0005(iyy),iyy= 1, 8) /112,104,121,115,105, 99, 97,108/ + data (st0005(iyy),iyy= 9, 9) / 0/ + if (.not.(im .eq. 0)) goto 110 + goto 100 +110 continue + nc = meml(refim+200 +1+8-1) + nl = meml(refim+200 +2+8-1) + ncpm = meml(im+200 +1+8-1) + nlpm = meml(im+200 +2+8-1) + pm = imstai (im, 16 ) + if (.not.(pmempy(pm) .and. nc .eq. ncpm .and. nl .eq. nlpm)) + * goto 120 + goto 100 +120 continue + mw = mwopem (im) + if (xerflg) goto 100 + call mwgltd (mw, lt, lt(5), 2) + call mwcloe (mw) + mw = mwopem (refim) + if (xerflg) goto 100 + call mwgltd (mw, lt2, lt2(5), 2) + call mwcloe (mw) + call mwinvd (lt, lt1, 2) + call mwmmud (lt1, lt2, lt, 2) + call mwvmud (lt, lt(5), lt(5), 2) + lt(5) = lt2(5) - lt(5) + lt(6) = lt2(6) - lt(6) + do 130 i = 1, 6 + lt(i) = nint (1d6 * (lt(i)-int(lt(i)))) / 1d6 + int(lt(i)) +130 continue +131 continue + if (.not.(lt(2) .ne. 0. .or. lt(3) .ne. 0.)) goto 140 + call xerror(1, st0001) + if (xerflg) goto 100 +140 continue + if (.not.(lt(1) .eq. 1d0 .and. lt(4) .eq. 1d0 .and. lt(5) .eq. + * 0d0 .and. lt(6) .eq. 0d0)) goto 150 + goto 100 +150 continue + mw = mwopem (im) + if (xerflg) goto 100 + call mwsltd (mw, lt, lt(5), 2) + ctx = mwsctn (mw, st0002, st0003, 1) + cty = mwsctn (mw, st0004, st0005, 2) + pmnew = plopen(0) + if (xerflg) goto 100 + call plssie(pmnew, 2, meml(refim+200 +1+8-1) , 27) + imnew = impmmo (pmnew, 0) + bufref = imgl1i (imnew) + call mwctrd (ctx, 1-0.5d0, x1, 1) + call mwctrd (ctx, nc+0.5d0, x2, 1) + i1 = max (1, nint(min(x1,x2)+1d-5)) + i2 = min (ncpm, nint(max(x1,x2)-1d-5)) + call mwctrd (cty, 1-0.5d0, y1, 1) + call mwctrd (cty, nl+0.5d0, y2, 1) + j1 = max (1, nint(min(y1,y2)+1d-5)) + j2 = min (nlpm, nint(max(y1,y2)-1d-5)) + if (.not.(i1 .le. i2 .and. j1 .le. j2)) goto 160 + nx = i2 - i1 + 1 + call xmallc(bufpm, nx, 4) + call xmallc(bufref, nc, 4) + vold(1) = i1 + vnew(1) = 1 + do 170 j = 1, nl + call mwctrd (cty, j-0.5d0, y1, 1) + call mwctrd (cty, j+0.5d0, y2, 1) + j1 = max (1, nint(min(y1,y2)+1d-5)) + j2 = min (nlpm, nint(max(y1,y2)-1d-5)) + if (.not.(j2 .lt. j1)) goto 180 + goto 170 +180 continue + vnew(2) = j + call aclri (memi(bufref), nc) + do 190 l = j1, j2 + vold(2) = l + if (.not.(.not.pmliny (pm, vold))) goto 200 + goto 190 +200 continue + call pmglpi (pm, vold, memi(bufpm), 0, nx, 0) + do 210 i = 1, nc + call mwctrd (ctx, i-0.5d0, x1, 1) + call mwctrd (ctx, i+0.5d0, x2, 1) + i1 = max (1, nint(min(x1,x2)+1d-5)) + i2 = min (ncpm, nint(max(x1,x2)-1d-5)) + if (.not.(i2 .lt. i1)) goto 220 + goto 210 +220 continue + val = memi(bufref+i-1) + do 230 k = i1-vold(1), i2-vold(1) + val = max (val, memi(bufpm+k)) +230 continue +231 continue + memi(bufref+i-1) = val +210 continue +211 continue +190 continue +191 continue + call pmplpi (pmnew, vnew, memi(bufref), 0, nc, 12 ) +170 continue +171 continue + call xmfree(bufref, 4) + call xmfree(bufpm, 4) +160 continue + call mwcloe (mw) + call imunmp (im) + im = imnew + call imseti (im, 16 , pmnew) +100 return + end +c pmliny pm_linenotempty +c mwmmud mw_mmuld +c errcoe errcode +c mwsltd mw_sltermd +c mwinvd mw_invertd +c impmmo im_pmmapo +c plssie pl_ssize +c mwctrd mw_ctrand +c pmempy pm_empty +c mwvmud mw_vmuld +c dsmath ds_match +c plopen pl_open +c mwsavm mw_saveim +c mwopem mw_openim +c imunmp imunmap +c mwsctn mw_sctran +c impmmp im_pmmap +c dspmip ds_pmimmap +c dspmmp ds_pmmap +c imstai imstati +c nowhie nowhite +c mwcloe mw_close +c pmnewk pm_newmask +c mwgltd mw_gltermd diff --git a/vendor/x11iraf/ximtool/clients.old/lib/dspmmap.x b/vendor/x11iraf/ximtool/clients.old/lib/dspmmap.x new file mode 100644 index 00000000..621f0372 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/dspmmap.x @@ -0,0 +1,244 @@ +include <mach.h> +include <ctype.h> +include <error.h> +include <imhdr.h> +include <imset.h> +include <pmset.h> +include <syserr.h> + + +# DS_PMMAP -- Open a pixel mask READ_ONLY. +# +# Open the pixel mask. If a regular image is specified convert it to +# a pixel mask. Match the mask to the reference image based on the +# physical coordinates. A null filename is allowed and returns NULL. + +pointer procedure ds_pmmap (pmname, refim) + +char pmname[ARB] #I Pixel mask name +pointer refim #I Reference image pointer + +pointer im +char fname[SZ_FNAME] +int nowhite(), errcode() +bool streq() +pointer im_pmmap(), ds_pmimmap() +errchk ds_pmimmap, ds_match + +begin + if (nowhite (pmname, fname, SZ_FNAME) == 0) + return (NULL) + if (streq (fname, "EMPTY")) + return (NULL) + if (fname[1] == '!') { + iferr (call imgstr (refim, fname[2], fname, SZ_FNAME)) + fname[1] = EOS + } else if (streq (fname, "BPM")) { + iferr (call imgstr (refim, "BPM", fname, SZ_FNAME)) + return (NULL) + } + + iferr (im = im_pmmap (fname, READ_ONLY, NULL)) { + switch (errcode()) { + case SYS_FOPNNEXFIL, SYS_PLBADSAVEF: + im = ds_pmimmap (fname, refim) + default: + call erract (EA_ERROR) + } + } + + iferr (call ds_match (im, refim)) + call erract (EA_WARN) + + return (im) +end + + +# DS_PMIMMAP -- Open a pixel mask from a non-pixel list image. +# Return error if the image cannot be opened. + +pointer procedure ds_pmimmap (pmname, refim) + +char pmname[ARB] #I Image name +pointer refim #I Reference image pointer + +int i, ndim, npix, val +pointer sp, v1, v2, im_in, im_out, pm, mw, data + +int imgnli() +pointer immap(), pm_newmask(), im_pmmapo(), imgl1i(), mw_openim() +errchk immap, mw_openim + +begin + call smark (sp) + call salloc (v1, IM_MAXDIM, TY_LONG) + call salloc (v2, IM_MAXDIM, TY_LONG) + + call amovkl (long(1), Meml[v1], IM_MAXDIM) + call amovkl (long(1), Meml[v2], IM_MAXDIM) + + im_in = immap (pmname, READ_ONLY, 0) + pm = pm_newmask (im_in, 27) + + ndim = IM_NDIM(im_in) + npix = IM_LEN(im_in,1) + + while (imgnli (im_in, data, Meml[v1]) != EOF) { + do i = 0, npix-1 { + val = Memi[data+i] + if (val < 0) + Memi[data+i] = 0 + } + call pmplpi (pm, Meml[v2], Memi[data], 0, npix, PIX_SRC) + call amovl (Meml[v1], Meml[v2], ndim) + } + + im_out = im_pmmapo (pm, im_in) + data = imgl1i (im_out) # Force I/O to set header + mw = mw_openim (im_in) # Set WCS + call mw_saveim (mw, im_out) + call mw_close (mw) + + call imunmap (im_in) + call sfree (sp) + return (im_out) +end + + +# DS_MATCH -- Set the pixel mask to match the reference image. +# This matches sizes and physical coordinates and allows the +# original mask to be smaller or larger than the reference image. +# Subsequent use of the pixel mask can then work in the logical +# coordinates of the reference image. The mask values are the maximum +# of the mask values which overlap each reference image pixel. +# A null input returns a null output. + +procedure ds_match (im, refim) + +pointer im #U Pixel mask image pointer +pointer refim #I Reference image pointer + +int i, j, k, l, i1, i2, j1, j2, nc, nl, ncpm, nlpm, nx, val +double x1, x2, y1, y2, lt[6], lt1[6], lt2[6] +long vold[IM_MAXDIM], vnew[IM_MAXDIM] +pointer pm, pmnew, imnew, mw, ctx, cty, bufref, bufpm + +int imstati() +pointer pm_open(), mw_openim(), im_pmmapo(), imgl1i(), mw_sctran() +bool pm_empty(), pm_linenotempty() +errchk pm_open, mw_openim + +begin + if (im == NULL) + return + + # Set sizes. + nc = IM_LEN(refim,1) + nl = IM_LEN(refim,2) + ncpm = IM_LEN(im,1) + nlpm = IM_LEN(im,2) + + # If the mask is empty and the sizes are the same then it does not + # matter if the two are actually matched in physical coordinates. + pm = imstati (im, IM_PMDES) + if (pm_empty(pm) && nc == ncpm && nl == nlpm) + return + + # Compute transformation between reference (logical) coordinates + # and mask (physical) coordinates. + + mw = mw_openim (im) + call mw_gltermd (mw, lt, lt[5], 2) + call mw_close (mw) + + mw = mw_openim (refim) + call mw_gltermd (mw, lt2, lt2[5], 2) + call mw_close (mw) + + # Combine lterms. + call mw_invertd (lt, lt1, 2) + call mw_mmuld (lt1, lt2, lt, 2) + call mw_vmuld (lt, lt[5], lt[5], 2) + lt[5] = lt2[5] - lt[5] + lt[6] = lt2[6] - lt[6] + do i = 1, 6 + lt[i] = nint (1D6 * (lt[i]-int(lt[i]))) / 1D6 + int(lt[i]) + + # Check for a rotation. For now don't allow any rotation. + if (lt[2] != 0. || lt[3] != 0.) + call error (1, "Image and mask have a relative rotation") + + # Check for an exact match. + if (lt[1] == 1D0 && lt[4] == 1D0 && lt[5] == 0D0 && lt[6] == 0D0) + return + + # Set reference to mask coordinates. + mw = mw_openim (im) + call mw_sltermd (mw, lt, lt[5], 2) + ctx = mw_sctran (mw, "logical", "physical", 1) + cty = mw_sctran (mw, "logical", "physical", 2) + + # Create a new pixel mask of the required size and offset. + # Do dummy image I/O to set the header. + pmnew = pm_open (NULL) + call pm_ssize (pmnew, 2, IM_LEN(refim,1), 27) + imnew = im_pmmapo (pmnew, NULL) + bufref = imgl1i (imnew) + + # Compute region of mask overlapping the reference image. + call mw_ctrand (ctx, 1-0.5D0, x1, 1) + call mw_ctrand (ctx, nc+0.5D0, x2, 1) + i1 = max (1, nint(min(x1,x2)+1D-5)) + i2 = min (ncpm, nint(max(x1,x2)-1D-5)) + call mw_ctrand (cty, 1-0.5D0, y1, 1) + call mw_ctrand (cty, nl+0.5D0, y2, 1) + j1 = max (1, nint(min(y1,y2)+1D-5)) + j2 = min (nlpm, nint(max(y1,y2)-1D-5)) + + # Set the new mask values to the maximum of all mask values falling + # within each reference pixel in the overlap region. + if (i1 <= i2 && j1 <= j2) { + nx = i2 - i1 + 1 + call malloc (bufpm, nx, TY_INT) + call malloc (bufref, nc, TY_INT) + vold[1] = i1 + vnew[1] = 1 + do j = 1, nl { + call mw_ctrand (cty, j-0.5D0, y1, 1) + call mw_ctrand (cty, j+0.5D0, y2, 1) + j1 = max (1, nint(min(y1,y2)+1D-5)) + j2 = min (nlpm, nint(max(y1,y2)-1D-5)) + if (j2 < j1) + next + + vnew[2] = j + call aclri (Memi[bufref], nc) + do l = j1, j2 { + vold[2] = l + if (!pm_linenotempty (pm, vold)) + next + call pmglpi (pm, vold, Memi[bufpm], 0, nx, 0) + do i = 1, nc { + call mw_ctrand (ctx, i-0.5D0, x1, 1) + call mw_ctrand (ctx, i+0.5D0, x2, 1) + i1 = max (1, nint(min(x1,x2)+1D-5)) + i2 = min (ncpm, nint(max(x1,x2)-1D-5)) + if (i2 < i1) + next + val = Memi[bufref+i-1] + do k = i1-vold[1], i2-vold[1] + val = max (val, Memi[bufpm+k]) + Memi[bufref+i-1] = val + } + } + call pmplpi (pmnew, vnew, Memi[bufref], 0, nc, PIX_SRC) + } + call mfree (bufref, TY_INT) + call mfree (bufpm, TY_INT) + } + + call mw_close (mw) + call imunmap (im) + im = imnew + call imseti (im, IM_PMDES, pmnew) +end diff --git a/vendor/x11iraf/ximtool/clients.old/lib/idxstr.f b/vendor/x11iraf/ximtool/clients.old/lib/idxstr.f new file mode 100644 index 00000000..ac16febf --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/idxstr.f @@ -0,0 +1,44 @@ + integer function idxstr (index, outstr, maxch, dict) + integer index + integer maxch + integer*2 outstr(*) + integer*2 dict(*) + integer i + integer len + integer start + integer count + integer xstrln + save + outstr(1) = 0 + if (.not.(dict(1) .eq. 0)) goto 110 + idxstr = (0) + goto 100 +110 continue + count = 1 + len = xstrln(dict) + start = 2 +120 if (.not.(count .lt. index)) goto 122 + if (.not.(dict(start) .eq. dict(1))) goto 130 + count = count + 1 +130 continue + if (.not.(start .eq. len)) goto 140 + idxstr = (0) + goto 100 +140 continue +121 start = start + 1 + goto 120 +122 continue + i = start +150 if (.not.(dict(i) .ne. 0 .and. dict(i) .ne. dict(1))) goto 152 + if (.not.(i - start + 1 .gt. maxch)) goto 160 + goto 152 +160 continue + outstr(i - start + 1) = dict(i) +151 i = i + 1 + goto 150 +152 continue + outstr(i - start + 1) = 0 + idxstr = (count) + goto 100 +100 return + end diff --git a/vendor/x11iraf/ximtool/clients.old/lib/idxstr.x b/vendor/x11iraf/ximtool/clients.old/lib/idxstr.x new file mode 100644 index 00000000..7b055658 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/idxstr.x @@ -0,0 +1,54 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + + +# IDXSTR -- Search a dictionary string for a given string index number. +# This is the opposite function of strdic(), that returns the index for +# given string. The entries in the dictionary string are separated by +# a delimiter character which is the first character of the dictionary +# string. The index of the string found is returned as the function value. +# Otherwise, if there is no string for that index, a zero is returned. + +int procedure idxstr (index, outstr, maxch, dict) + +int index #i String index +char outstr[ARB] #o Output string as found in dictionary +int maxch #i Maximum length of output string +char dict[ARB] #i Dictionary string + +int i, len, start, count + +int strlen() + +begin + # Clear the output string. + outstr[1] = EOS + + # Return if the dictionary is not long enough. + if (dict[1] == EOS) + return (0) + + # Initialize the counters. + count = 1 + len = strlen (dict) + + # Search the dictionary string. This loop only terminates + # successfully if the index is found. Otherwise the procedure + # returns with and error condition. + for (start = 2; count < index; start = start + 1) { + if (dict[start] == dict[1]) + count = count + 1 + if (start == len) + return (0) + } + + # Extract the output string from the dictionary. + for (i = start; dict[i] != EOS && dict[i] != dict[1]; i = i + 1) { + if (i - start + 1 > maxch) + break + outstr[i - start + 1] = dict[i] + } + outstr[i - start + 1] = EOS + + # Return index for output string. + return (count) +end diff --git a/vendor/x11iraf/ximtool/clients.old/lib/mkpkg b/vendor/x11iraf/ximtool/clients.old/lib/mkpkg new file mode 100644 index 00000000..3c6a6c14 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/mkpkg @@ -0,0 +1,17 @@ +# Make the ISM Client tasks. + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + @skywcs + idxstr.x + reopen.x <config.h> <fio.com> <fio.h> + dspmmap.x <ctype.h> <error.h> <imhdr.h> <imset.h> \ + <mach.h> <pmset.h> + wcsgfterm.x + ximtool.x <config.h> <mach.h> <xwhen.h> + ; + diff --git a/vendor/x11iraf/ximtool/clients.old/lib/reopen.f b/vendor/x11iraf/ximtool/clients.old/lib/reopen.f new file mode 100644 index 00000000..f7a1c456 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/reopen.f @@ -0,0 +1,70 @@ + integer function reopen (fd, mode) + integer fd + integer mode + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer newfp + integer ffp + integer newfd + integer fgetfd + integer*4 boffst(4096 ) + integer bufptr(4096 ) + integer buftop(4096 ) + integer iop(4096 ) + integer itop(4096 ) + integer otop(4096 ) + integer fiodes(4096 ) + integer fflags(4096 ) + integer redird(4096 ) + integer zdev(150 ) + integer nextdv + integer fp + integer*2 pathne(511 +1) + logical xerflg + common /xercom/ xerflg + common /fiocom/ boffst, bufptr, buftop, iop, itop, otop, fiodes, + *fflags, redird, zdev, nextdv, fp, pathne + save + ffp = fiodes(fd) + if (.not.(fd .le. 0 .or. ffp .eq. 0)) goto 110 + call syserr (733) + if (xerflg) goto 100 +110 continue + if (.not.(memi(ffp+1) .eq. 1 .and. mode .ne. 1 )) goto 120 + call filerr (memc((((ffp+20+(10+256))-1)*2+1)) , 750) +120 continue + if (.not.(memi(ffp+2) .ne. 12)) goto 130 + call filerr (memc((((ffp+20+(10+256))-1)*2+1)) , 751) +130 continue + newfd = fgetfd (memc((((ffp+20+(10+256))-1)*2+1)) , mode, 12) + newfp = fiodes(newfd) + memi(newfp+3) = memi(ffp+3) + memi(newfp+4) = memi(ffp+4) + memi(newfp) = memi(ffp) + if (.not.(memi(ffp+18) .eq. (ffp+20) )) goto 140 + call xmallc(memi(ffp+18) , (10+256), 10 ) + if (xerflg) goto 100 + call amovi (memi((ffp+20) ), memi(memi(ffp+18) ), (10+256)) +140 continue + memi(memi(ffp+18) ) = memi(memi(ffp+18) ) + 1 + memi(newfp+18) = memi(ffp+18) + if (.not.(mode .eq. 4)) goto 150 + call xfseek(newfd, -2) + if (xerflg) goto 100 +150 continue + reopen = (newfd) + goto 100 +100 return + end +c nextdv next_dev +c boffst boffset +c redird redir_fd +c pathne pathname diff --git a/vendor/x11iraf/ximtool/clients.old/lib/reopen.x b/vendor/x11iraf/ximtool/clients.old/lib/reopen.x new file mode 100644 index 00000000..59ddba30 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/reopen.x @@ -0,0 +1,55 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <config.h> +include <syserr.h> +include <fio.h> + +# REOPEN -- Reopen a binary file. Used to gain two or more independent +# sets of buffers to access a binary file. No protection against two +# file descriptors trying to write to the same part of the file at the +# same time, which may result in loss of data. The file descriptors and +# buffers of reopened files are independent, but all files accessing the +# same channel share the same channel descriptor (necessary to synchronize +# i/o requests and to maintain a unique file size parameter). + +int procedure reopen (fd, mode) + +int fd, mode +pointer newfp, ffp +int newfd, fgetfd() +errchk syserr, malloc, seek +include <fio.com> + +begin + ffp = fiodes[fd] + if (fd <= 0 || ffp == NULL) + call syserr (SYS_FILENOTOPEN) + + if (FMODE(ffp) == READ_ONLY && mode != READ_ONLY) + call filerr (FNAME(ffp), SYS_FREOPNMODE) + if (FTYPE(ffp) != BINARY_FILE) + call filerr (FNAME(ffp), SYS_FREOPNTYPE) + + newfd = fgetfd (FNAME(ffp), mode, BINARY_FILE) + newfp = fiodes[newfd] + + FDEV(newfp) = FDEV(ffp) + FBUFSIZE(newfp) = FBUFSIZE(ffp) + FCHAN(newfp) = FCHAN(ffp) + + # If this is the first reopen, allocate space for a separate channel + # descriptor and copy the channel descriptor from the original file. + + if (FCD(ffp) == FLCD(ffp)) { + call malloc (FCD(ffp), LEN_CHANDES, TY_STRUCT) + call amovi (Memi[FLCD(ffp)], Memi[FCD(ffp)], LEN_CHANDES) + } + + FREFCNT(ffp) = FREFCNT(ffp) + 1 # bump ref count + FCD(newfp) = FCD(ffp) + + if (mode == APPEND) + call seek (newfd, EOFL) + + return (newfd) +end diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/README b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/README new file mode 100644 index 00000000..d15ab738 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/README @@ -0,0 +1,302 @@ + SKYWCS: The Sky Coordinates Package + +1. Introduction + + The skywcs package contains a simple set of routines for doing managing sky +coordinate information and for transforming from one sky coordinate system to +another. The sky coordinate system is defined either by a system name, e.g. +"J2000", "galactic, etc., or by an image system name, e.g. "dev$ypix" or +"dev$ypix world". + + The skywcs routine are layered on the Starlink Positional Astronomy library +SLALIB which is installed in the IRAF MATH package. Type "help slalib option= +sys" for more information about SLALIB. + + +2. The Interface Routines + +The package prefix is sk. The interface routines are listed below. + + stat = sk_decwcs (ccsystem, mw, coo, imcoo) + stat = sk_decwstr (ccsystem, coo, imcoo) + stat = sk_decim (im, wcs, mw, coo) + sk_enwcs (coo, ccsystem, maxch) + newcoo = sk_copy (coo) + sk_iiprint (label, imagesys, mw, coo) + sk_iiwrite (fd, label, imagesys, mw, coo) +[id]val = sk_stat[id] (coo, param) + sk_stats (coo, param, str, maxch) + sk_set[id] (coo, param, [id]val) + sk_sets (coo, param, str) + sk_ultran (incoo, outcoo, ilng, ilat, olng, olat, npts) + sk_lltran (incoo, outoo, ilng, ilat, ipmlng, ipmlat, px, rv, + olng, olat) + sk_equatorial (incoo, outcoo, ilng, ilat, ipmlng, ipmlat, px, + rv, olng, olat) + sk_saveim (coo, mw, im) + sk_close (coo) + + +3. Notes + + An "include <pkg/skywcs.h>" statement must be included in the calling +program to make the skywcs package parameter definitions visible to the calling +program. + + An "-lxtools -lslalib" must be included in the calling program link line +to link in the skywcs and the slalib routines. + + The sky coordinate descriptor is created with a call to one of the +sk_decwcs, sk_decwstr, or sk_imwcs routines. If the source of the sky +coordinate descriptor is an image then an IRAF MWCS descriptor will be returned +with the sky oordinate descriptor. The sky coordinate descriptor is freed with a +call to sk_close. A separate call to mw_close must be made to free the MWCS +descriptor if one was allocated. + + By default the main skywcs coordinate transformation routine sk_ultran +assumes that the input and output sky coordinates are in hours and degrees +if the input and output coordinate systems are equatorial, otherwise the +coordinates are assumed to be in degrees and degrees. The default input and +output sky coordinate units can be reset with calls to sk_seti. Two lower level +coordinate transformations for handling proper motions sk_lltran and +sk_equatorial are also available. These routines that the input and output +coordinates and proper motions are in radians. + + Calling programs working with both sky coordinate and MWCS descriptors +need to be aware that the MWCS routines assume that all sky coordinates +must be input in degrees and will be output in degrees and adjust their +code accordingly. + + The skywcs routine sk_saveim can be used to update an image header. + + +3. Examples + +Example 1: Convert from B1950 coordinates to J2000 coordinates. + + include <skywcs.h> + + .... + + # Open input coordinate system. + instat = sk_decwstr ("B1950", incoo, NULL) + if (instat == ERR) { + call sk_close (incoo) + return + } + + # Open output coordinate system. + outstat = sk_decwstr ("J2000", outcoo, NULL) + if (outstat == ERR) { + call sk_close (outcoo) + return + } + + # Do the transformation assuming the input coordinates are in hours + # and degrees. The output coordinates will be in hours and degrees + # as well. + call sk_ultran (incoo, outcoo, rain, decin, raout, decout, npts) + + # Close the coordinate descriptors. + call sk_close (incoo) + call sk_close (outcoo) + + ... + + +Example 2: Repeat example 1 but convert to galactic coordinates. + + include <skywcs.h> + + .... + + # Open the input coordinate system. + instat = sk_decwstr ("B1950", incoo, NULL) + if (instat == ERR) { + call sk_close (incoo) + return + } + + # Open the output coordinate system. + outstat = sk_decwstr ("galactic", outcoo, NULL) + if (outstat == ERR) { + call sk_close (outcoo) + return + } + + # Dd the transformation assuming the input coordinates are in hours and + # degrees. The output coordinates will be in degrees and degrees. + call sk_ultran (incoo, outcoo, rain, decin, raout, decout, npts) + + # Close the coordinate descriptors. + call sk_close (incoo) + call sk_close (outcoo) + + ... + +Example 3: Convert a grid of pixel coordinates in the input image to the +equivalent pixel coordinate in the output image using the image world +coordinate systems to connect the two. + + include <skywcs.h> + + .... + + # Mwref will be defined because the input system is an image. + refstat = sk_decwcs ("refimage logical", mwref, refcoo, NULL) + if (refstat == ERR || mwref == NULL) { + if (mwref != NULL) + call mw_close (mwref) + call sk_close (refcoo) + return + } + + # Set the reference coordinate descriptor so it expects input in degrees + # and degrees. + call sk_seti (refcoo, S_NLNGUNUTS, SKY_DEGREES) + call sk_seti (refcoo, S_NLATUNUTS, SKY_DEGREES) + + # Mwout will be defined because the output system is an image. + outstat = sk_decwcs ("image logical", mwout, outcoo, NULL) + if (outstat == ERR || mwout == NULL) { + if (mwout != NULL) + call mw_close (mwout) + call sk_close (outcoo) + call mw_close (mwref) + call sk_close (refcoo) + return + } + + # Set the output coordinate descriptor so it will output coordinates + # in degrees and degrees. + call sk_seti (outcoo, S_NLNGUNUTS, SKY_DEGREES) + call sk_seti (outcoo, S_NLATUNUTS, SKY_DEGREES) + + # Compute pixel grid in refimage and store coordinate in the arrays + # xref and yref. + npts = 0 + do j = 1, IM_LEN(im,2), 100 { + do i = 1, IM_LEN(im,1), 100 { + npts = npts + 1 + xref[npts] = i + yref[npts] = j + } + } + + # Convert xref and yref to celestial coordinates raref and decref using + # mwref. The output coordinates will be in degrees and degrees. + ctref = mw_sctran (mwref, "logical", "world", 03B) + do i = 1, npts + call mw_c2trand (ctref, xref[i], yref[i], raref[i], decref[i]) + call ct_free (ctref) + + # Convert the reference celestial coordinates to the output celestial + # coordinate system using the coordinate descriptors. + call sk_ultran (refcoo, outcoo, raref, decref, raout, decout, npts) + + # Convert the output celestial coordinates to pixel coordinates in + # the other image using mwout. + ctout = mw_sctran (mwout, "world", "logical", 03B) + do i = 1, npts + call mw_c2trand (ctout, raout[i], decout[i], xout[i], yout[i]) + call ct_free (ctout) + + # Print the input and output pixel coordinates. + do i = 1, npts { + call printf ("%10.3f %10.3f %10.3f %10.3f\n") + call pargd (xref[i]) + call pargd (yref[i]) + call pargd (xout[i]) + call pargd (yout[i]) + } + + # Tidy up. + call mw_close (mwref) + call mw_close (mwout) + call sk_close (refcoo) + call sk_close (outcoo) + + +Example 4: Convert a 2D image with an J2000 tangent plane projection wcs to the +equivalent galactic wcs. The transformation requires a shift in origin and a +rotation. Assume that the ra axis is 1 and the dec axis is 2. The details of +how to compute the rotation are not shown here. See the imcctran task for +details. + + include <mwset.h> + include <skywcs.h> + + ... + + # Open image. + im = immap (image, READ_WRITE, 0) + + # Open the image coordinate system. + instat = sk_decim (im, "logical", mwin, cooin) + if (instat == ERR || mwin == NULL) { + ... + call sk_close (cooin) + ... + } + + # Get the dimensions of the mwcs descriptor. This should be 2. + ndim = mw_ndim (mwin, MW_NPHYSDIM) + + # Get the default coordinates to degrees and degreees. + call sk_seti (cooin, S_NLNGUNITS, SKY_DEGREES) + call sk_seti (cooin, S_NATGUNITS, SKY_DEGREES) + + # Open the output coordinate system. Mwout is NULL because this system + # is not an image. + outstat = sk_decwstr ("galactic", mwout, cooout, cooin) + if (outstat == ERR) { + ... + call sk_close (outstat) + ... + } + + # Make a copy of the mwcs descriptor. + mwout = mw_newcopy (mwin) + + # Allocate space for the r and w vectors and cd matrix. + call malloc (r, ndim, TY_DOUBLE) + call malloc (w, ndim, TY_DOUBLE) + call malloc (cd, ndim * ndim, TY_DOUBLE) + call malloc (newcd, ndim * ndim, TY_DOUBLE) + + # Assume for simplicty that the MWCS LTERM is the identify transform. + # so we don't have to worry about it. Get the WTERM which consists + # of r the reference point in pixels, w the reference point in degrees, + # and the cd matrix in degrees per pixel. + call mw_gwtermd (mwin, Memd[r], Memd[w], Memd[cd], ndim) + + # Convert the world coordinates zero point. The pixel zero point + # remains the same. + tilng = Memd[w] + tilat = Memd[w+1] + call sk_ultran (incoo, outcoo, tilng, tilat, tolng, tolat, 1) + Memd[w] = tolng + Memd[w+1] = tolat + + # Figure out how much to rotate the coordinate system and edit the + # compute a new CD matrix. Call it newcd. + ... + + # Enter the new CD matrix and zero point. + call mw_swterm (mwout, Memd[r], Memd[w], Memd[newcd], ndim) + + # Update the header. + call sk_saveim (cooout, mwout, im) + call mw_saveim (mwout, im) + ... + + # Tidy up. + call mfree (r, TY_DOUBLE) + call mfree (w, TY_DOUBLE) + call mfree (cd, TY_DOUBLE) + call mfree (newcd, TY_DOUBLE) + call mw_close (mwin) + call mw_close (mwout) + call sk_close (cooin) + call sk_close (cooout) + call imunmap (im) diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/ccsystems.hlp b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/ccsystems.hlp new file mode 100644 index 00000000..e812fc8d --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/ccsystems.hlp @@ -0,0 +1,134 @@ +.help ccsystems Mar00 Skywcs +.ih +NAME +ccsystems -- list and describe the supported sky coordinate systems +.ih +USAGE +help ccsystems + +.ih +SKY COORDINATE SYSTEMS + +The sky package supports the equatorial ("fk4", "fk4-noe", "fk5", "icrs"), +ecliptic, galactic, and supergalactic celestial coordinate systems. In most +cases and unless otherwise noted users can input their coordinates in +any one of these systems as long as they specify the coordinate system +correctly. + +Considerable flexibility is permitted in how the coordinate systems are +specified, e.g. J2000.0, j2000.0, 2000.0, fk5, fk5 J2000, and fk5 2000.0 +all specify the mean place post-IAU 1976 or FK5 system. Missing equinox and +epoch fields assume reasonable defaults. In most cases the +systems of most interest to users are are "icrs", "j2000", and "b1950" +which stand for the ICRS J2000.0, FK5 J2000.0 and FK4 B1950.0 celestial +coordinate systems respectively. The full set of options are listed below: + +.ls equinox [epoch] +The equatorial mean place post-IAU 1976 (FK5) system if equinox is a +Julian epoch, e.g. J2000.0 or 2000.0, or the equatorial mean place +pre-IAU 1976 system (FK4) if equinox is a Besselian epoch, e.g. B1950.0 +or 1950.0. Julian equinoxes are prefixed by a J or j, Besselian equinoxes +by a B or b. Equinoxes without the J / j or B / b prefix are treated as +Besselian epochs if they are < 1984.0, Julian epochs if they are >= 1984.0. +Epoch is the epoch of the observation and may be a Julian +epoch, a Besselian epoch, or a Julian date. Julian epochs +are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to the epoch type of +equinox if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. If undefined epoch defaults to equinox. +.le +.ls icrs [equinox] [epoch] +The International Celestial Reference System where equinox is +a Julian or Besselian epoch e.g. J2000.0 or B1980.0. +Equinoxes without the J / j or B / b prefix are treated as Julian epochs. +The default value of equinox is J2000.0. +Epoch is a Besselian epoch, a Julian epoch, or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. If undefined epoch defaults to equinox. +.le +.ls fk5 [equinox] [epoch] +The equatorial mean place post-IAU 1976 (FK5) system where equinox is +a Julian or Besselian epoch e.g. J2000.0 or B1980.0. +Equinoxes without the J / j or B / b prefix are treated as Julian epochs. +The default value of equinox is J2000.0. +Epoch is a Besselian epoch, a Julian epoch, or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. If undefined epoch defaults to equinox. +.le +.ls fk4 [equinox] [epoch] +The equatorial mean place pre-IAU 1976 (FK4) system where equinox is a +Besselian or Julian epoch e.g. B1950.0 or J2000.0, +and epoch is the Besselian epoch, the Julian epoch, or the Julian date of the +observation. +Equinoxes without the J / j or B / b prefix are treated +as Besselian epochs. The default value of equinox is B1950.0. Epoch +is a Besselian epoch, a Julian epoch, or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. If undefined epoch defaults to equinox. +.le +.ls noefk4 [equinox] [epoch] +The equatorial mean place pre-IAU 1976 (FK4) system but without the E-terms +where equinox is a Besselian or Julian epoch e.g. B1950.0 or J2000.0, +and epoch is the Besselian epoch, the Julian epoch, or the Julian date of the +observation. +Equinoxes without the J / j or B / b prefix are treated +as Besselian epochs. The default value of equinox is B1950.0. +Epoch is a Besselian epoch, a Julian epoch, or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian day. If undefined epoch defaults to equinox. +.le +.ls apparent epoch +The equatorial geocentric apparent place post-IAU 1976 system where +epoch is the epoch of observation. +Epoch is a Besselian epoch, a Julian epoch or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian +epochs if the epoch value < 1984.0, Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. +.le +.ls ecliptic epoch +The ecliptic coordinate system where epoch is the epoch of observation. +Epoch is a Besselian epoch, a Julian epoch, or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian epochs +if the epoch values < 1984.0, Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian day. +.le +.ls galactic [epoch] +The IAU 1958 galactic coordinate system. +Epoch is a Besselian epoch, a Julian epoch or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian +epochs if the epoch value < 1984.0, Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. The default value of epoch is B1950.0. +.le +.ls supergalactic [epoch] +The deVaucouleurs supergalactic coordinate system. +Epoch is a Besselian epoch, a Julian epoch or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian +epochs if the epoch value < 1984.0, Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. The default value of epoch is B1950.0. +.le + +Fields enclosed in [] are optional with the defaults as described. The epoch +field for the "icrs" , "fk5", "galactic", and "supergalactic" coordinate +systems is only used if the input coordinates are in the equatorial fk4, +noefk4, fk5, or icrs systems and proper motions are used to transform from +coordinate system to another. + +.ih +SEE ALSO +.endhelp diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skclose.hlp b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skclose.hlp new file mode 100644 index 00000000..191b08b5 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skclose.hlp @@ -0,0 +1,23 @@ +.help skclose Mar00 Skywcs +.ih +NAME +skclose -- free the sky coordinate descriptor +.ih +SYNOPSIS +call sk_close (coo) + +.nf +pointer coo # the sky coordinate descriptor +.fi +.ih +ARGUMENTS +.ls coo +The sky coordinate descriptor to be freed. +.le +.ih +DESCRIPTION +Sk_close frees a previously allocated sky coordinate descriptor. +.ih +SEE ALSO +skdecwcs, skdecwstr, skdecim, skcopy +.endhelp diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skcopy.hlp b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skcopy.hlp new file mode 100644 index 00000000..68219c0d --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skcopy.hlp @@ -0,0 +1,24 @@ +.help skcopy Mar00 Skywcs +.ih +NAME +skcopy -- copy a sky coordinate descriptor +.ih +SYNOPSIS +newcoo = sk_copy (coo) + +.nf +pointer coo # the sky coordinate descriptor +.fi +.ih +ARGUMENTS +.ls coo +The sky coordinate descriptor to be copied. +.le +.ih +DESCRIPTION +Sk_copy is a pointer function which returns a copy of the input sky coordinate +descriptor as its function value. +.ih +SEE ALSO +skdecwcs, skdecwstr, skdecim, skclose +.endhelp diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skdecim.hlp b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skdecim.hlp new file mode 100644 index 00000000..c8f7b2e7 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skdecim.hlp @@ -0,0 +1,55 @@ +.help skdecim Mar00 Skywcs +.ih +NAME +skdecim -- open a sky coordinate descriptor using an image descriptor +.ih +SYNOPSIS +stat = sk_decim (im, mw, coo, imcoo) + +.nf +pointer im # the input image descriptor +pointer mw # the output mwcs descriptor +pointer coo # the output sky coordinate descriptor +pointer imcoo # the input image sky coordinate descriptor +.fi +.ih +ARGUMENTS +.ls im +The input image descriptor. +.le +.ls mw +The output mwcs descriptor. A NULL value for mw is returned if the image +world coordinate system cannot be read. +.le +.ls coo +The output sky coordinate descriptor. +.le +.ls imcoo +The parent image sky coordinate descriptor. Imcoo is set to NULL +except in cases where the sky coordinate descriptor for an image is +transformed and written back to the same image. +.ih +DESCRIPTION +Sk_decim is an integer function which returns OK or ERR as its function +value. ERR is returned if a valid sky coordinate system cannot be opened, +OK otherwise. + +Sk_decim returns the image MWCS descriptor mw. The MWCS descriptor is used +to convert from pixel coordinates to world coordinates and vice versa. +The MWCS descriptor must be freed with a call to the MWCS routine +mw_close before task termination. + +Sk_decim returns the sky descriptor coo. The sky coordinate descriptor +is defined even if an error is detected in reading the image celestial +coordinate system, and must be freed with a call to sk_close before +task termination. + +.ih +NOTES +Type "help ccsystems" to see the list of the supported sky coordinate systems. + +Type "help mwcs$MWCS.hlp fi+" to find out more about the IRAF image world +coordinate system library MWCS. +SEE ALSO +skdecwcs, skdecwstr, skcopy, skclose +.endhelp diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skdecwcs.hlp b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skdecwcs.hlp new file mode 100644 index 00000000..2081fd50 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skdecwcs.hlp @@ -0,0 +1,62 @@ +.help skdecwcs Mar00 Skywcs +.ih +NAME +skdecwcs -- open a sky coordinate descriptor using an image or system name +.ih +SYNOPSIS +stat = sk_decwcs (ccsystem, mw, coo, imcoo) + +.nf +char ccsystem # the input celestial coordinate system name +pointer mw # the output mwcs descriptor +pointer coo # the output sky coordinate descriptor +pointer imcoo # the input image sky coordinate descriptor +.fi +.ih +ARGUMENTS +.ls ccsystem. +The celestial coordinate system name. Ccsystem is a either an image system +name, e.g. "dev$ypix logical" or "dev$ypix world" or a system name, e.g. +"J2000" or "galactic". +.le +.ls mw +The output mwcs descriptor. A NULL value for mw is returned if the +image world coordinate system cannot be read or ccsystem is not an image +system name. +.le +.ls coo +The output sky coordinate descriptor. +.le +.ls imcoo +The parent image coordinate descriptor. Imcoo is set to NULL +except in cases where the sky coordinate descriptor for an image is +transformed and written back to the same image. +.le +.ih +DESCRIPTION +Sk_decwcs is an integer function which returns OK or ERR as its function +value. ERR is returned if a valid sky coordinate system cannot be opened, +OK otherwise. + +Sk_decwcs returns the image MWCS descriptor mw if ccsystem is an image +system, otherwise it returns NULL. The MWCS descriptor is used +to convert from pixel coordinates to world coordinates and vice versa. +The MWCS descriptor must be freed with a call to the MWCS routine +mw_close before task termination. + +Sk_decwcs returns the sky descriptor coo. The sky coordinate descriptor +is defined even if an error is detected in reading the image celestial +coordinate system, and must be freed with a call to sk_close before +task termination. + +.ih +NOTES +Type "help ccsystems" to see the list of the supported sky coordinate systems. + +Type "help mwcs$MWCS.hlp fi+" to find out more about the IRAF image world +coordinate system library MWCS. + + +SEE ALSO +skdecwstr, skdecim +.endhelp diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skdecwstr.hlp b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skdecwstr.hlp new file mode 100644 index 00000000..f81c2d48 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skdecwstr.hlp @@ -0,0 +1,46 @@ +.help skdecwstr Mar00 Skywcs +.ih +NAME +skdecwstr -- open a sky coordinate descriptor using a system name +.ih +SYNOPSIS +stat = sk_decwstr (csystem, coo, imcoo) + +.nf +char csystem # the input celestial coordinate system name +pointer coo # the output sky coordinate descriptor +pointer imcoo # the input image sky coordinate descriptor +.fi +.ih +ARGUMENTS +.ls csystem +The sky coordinates definition. Ccsystem is a system name, e.g. "J2000" +or "galactic. +.le +.ls coo +The output sky coordinate descriptor. +.le +.ls imcoo +The parent image coordinate descriptor. Imcoo is set to NULL +except in cases where the sky coordinate descriptor for an image is +transformed and written back to the same image. +.le +.ih +DESCRIPTION +Sk_decwstr is an integer function which returns OK or ERR as its function +value. ERR is returned if a valid sky coordinate system cannot be opened, +OK otherwise. + +Sk_decwstr returns the sky descriptor coo. The sky coordinate descriptor +is defined even if an error is detected in reading the image celestial +coordinate system, and must be freed with a call to sk_close before +task termination. + +.ih +NOTES + +Type "help ccsystems" to get a list of the supported sky coordinate systems. + +SEE ALSO +skdecwcs, skdecim, skcopy, skclose +.endhelp diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skenwcs.hlp b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skenwcs.hlp new file mode 100644 index 00000000..cc388108 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skenwcs.hlp @@ -0,0 +1,32 @@ +.help skenwcs Mar00 Skywcs +.ih +NAME +skenwcs -- encode a system name using a sky coordinate descriptor +.ih +SYNOPSIS + +call sk_enwcs (coo, csystem, maxch) + +.nf +pointer coo # the input sky coordinate descriptor +char csystem # the output system name +int maxch # the maximum size of the output system name +.fi +.ih +ARGUMENTS +.ls coo +The input sky coordinate descriptor +.le +.ls csystem +The output system name, e.g. "galactic". +.le +.ls maxch +The maximum size of the output system name. +.le +.ih +DESCRIPTION +Sk_enwcs returns the sky coordinate system name. +.ih +SEE ALSO +skdecwcs, skdecwstr +.endhelp diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skequatorial.hlp b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skequatorial.hlp new file mode 100644 index 00000000..4adc7590 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skequatorial.hlp @@ -0,0 +1,59 @@ +.help skequatorial Mar00 Skywcs +.ih +NAME +skequatorial -- apply pm and transform between equatorial coordinate systems +.ih +SYNOPSIS +call sk_equatorial (incoo, outcoo, ilng, ilat, ipmlng, ipmlat, px, rv, + olng, olat) + +.nf +pointer incoo # the input sky coordinate descriptor +pointer outcoo # the output sky coordinate descriptor +double ilng, ilat # the input sky coordinates in radians +double ipmlng, ipmlat # the input proper motions in radians / year +double px # the input parallax in arcsec +double rv # the input radial velocity in km / sec (+ve receding) +double olng, olat # the output output sky coordinates in radians +.fi +.ih +ARGUMENTS +.ls incoo +The input sky coordinate descriptor. +.le +.ls parameter +.ls outcoo +The output sky coordinate descriptor. +.le +.ls ilng, ilat +The input sky coordinates in radians. +.le +.ls ipmlng, ipmlat +The input proper motions. If proper motions are unknown do not set ipmlng +and ipmlat to 0.0, use sk_ultran instead. Note that the ra proper motion +is in dra not cos (dec) * dra units. +.le +.ls px +The parallax in arcseconds. Use 0.0 if the proper motion is unknown unknown. +The parallax value is used only if proper motions are defined. +.le +.ls rv +The radial velocity in km / sec. Use 0.0 if the radial velocity is unknown. +The radial velocity value is used only if proper motions are defined. +.le +.ls olng, olat +The output sky coordinates in radians. +.le +.ih +DESCRIPTION +The coordinates in the input sky coordinate system are converted to +coordinates in the output sky coordinate system. +.ih +NOTES +If the proper motions are undefined use the routine sk_ultran. Zero valued +proper motions are not the same as undefined proper motions. + +.ih +SEE ALSO +sk_lltran, sk_ultran +.endhelp diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skiiprint.hlp b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skiiprint.hlp new file mode 100644 index 00000000..217819c2 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skiiprint.hlp @@ -0,0 +1,39 @@ +.help skiiprint Mar00 Skywcs +.ih +NAME +skiiprint -- print the sky coordinate system summary +.ih +SYNOPSIS + +call sk_iprint (label, imagesys, mw, coo) + +.nf +char label # the input user label +char imagesys # the input image system +pointer mw # the input mwcs descriptor +pointer coo # the sky coordinate descriptor +.fi +.ih +ARGUMENTS +.ls label +The input user supplied label, e.g. "Input System", "Ref System", +"Output System" etc. +.le +.ls imagesys +The input image system, e.g. "dev$ypix logical", "dev$ypix world", etc. +.le +.ls mwcs +The input image mwcs descriptor if defined. If mwcs is defined then +information about which sky coordinate corresponds to which image +axis etc is read from the mwcs descriptor. +.le +.ls coo +The input sky coordinate descriptor. +.le +.ih +DESCRIPTION +A summary of the sky coordinate system is printed on the standard output. +.ih +SEE ALSO +skiiwrite +.endhelp diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skiiwrite.hlp b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skiiwrite.hlp new file mode 100644 index 00000000..c82472f4 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skiiwrite.hlp @@ -0,0 +1,43 @@ +.help skiiwrite Mar00 Skywcs +.ih +NAME +skiiwrite -- write the sky coordinate system summary to a file +.ih +SYNOPSIS + +call sk_iiwrite (outfd, label, imagesys, mw, coo) + +.nf +int outfd # the input file descriptor +char label # the input user label +char imagesys # the input image system +pointer mw # the input mwcs descriptor +pointer coo # the sky coordinate descriptor +.fi +.ih +ARGUMENTS +.ls outfd +The input file descriptor. +.le +.ls label +The input user supplied label, e.g. "Input System", "Ref System", +"Output System" etc. +.le +.ls imagesys +The input image system, e.g. "dev$ypix logical", "dev$ypix world", etc. +.le +.ls mwcs +The input image mwcs descriptor if defined. If mwcs is defined then +information about which sky coordinate corresponds to which image +axis etc is read from the mwcs descriptor. +.le +.ls coo +The input sky coordinate descriptor. +.le +.ih +DESCRIPTION +A summary of the sky coordinate system is written to a file. +.ih +SEE ALSO +skiiprint +.endhelp diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/sklltran.hlp b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/sklltran.hlp new file mode 100644 index 00000000..a0040507 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/sklltran.hlp @@ -0,0 +1,60 @@ +.help sklltran Mar00 Skywcs +.ih +NAME +sklltran -- apply pm and transform between coordinate systems +.ih +SYNOPSIS +call sk_lltran (incoo, outcoo, ilng, ilat, ipmlng, ipmlat, px, rv, olng, olat) + +.nf +pointer incoo # the input sky coordinate descriptor +pointer outcoo # the output sky coordinate descriptor +double ilng, ilat # the input sky coordinates in radians +double ipmlng, ipmlat # the input proper motions in radians / year +double px # the input parallax in arcsec +double rv # the input radial velocity in km / sec (+ve receding) +double olng, olat # the output sky coordinates in radians +.fi +.ih +ARGUMENTS +.ls incoo +The input sky coordinate descriptor. +.le +.ls parameter +.ls outcoo +The output sky coordinate descriptor. +.le +.ls ilng, ilat +The input sky coordinates in radians. +.le +.ls ipmlng, ipmlat +The input proper motions. For these to be applied the input coordinate +system must be an equatorial coordinate system. If proper motions are +unknown do not set ipmlng and ipmlat to 0.0, use sk_ultran instead. Note that +the ra proper motion is in dra not cos (dec) * dra units. +.le +.ls px +The parallax in arcseconds. Use 0.0 if the proper motion is unknown unknown. +The parallax value is used only if proper motions are defined. +.le +.ls rv +The radial velocity in km / sec. Use 0.0 if the radial velocity is unknown. +The radial velocity value is used only if proper motions are defined. +.le +.ls olng, olat +The onput sky coordinates in radians. +.le + +.ih +DESCRIPTION +The coordinates in the input sky coordinate system are converted to +coordinates in the output sky coordinate system. +.ih +NOTES +If the proper motions are undefined use the routine sk_ultran. Zero valued +proper motions are not the same as undefined proper motions. + +.ih +SEE ALSO +sk_ultran, sk_equatorial +.endhelp diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/sksaveim.hlp b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/sksaveim.hlp new file mode 100644 index 00000000..82c16f3f --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/sksaveim.hlp @@ -0,0 +1,39 @@ +.help sksaveim Mar00 Skywcs +.ih +NAME +sksaveim -- update the image header using a sky coordinate descriptor +.ih +SYNOPSIS +call sk_saveim (coo, mw, im) + +.nf +pointer coo # the input sky coordinate descriptor +pointer mw # the input mwcs descriptor +pointer im # the input image descriptor +.fi +.ih +ARGUMENTS +.ls coo +The input sky coordinate descriptor. +.le +.ls mw +The IRAF mwcs descriptor. +.le +.ls im +The input image descriptor. +.le +.ih +DESCRIPTION +The image world coordinate system is updated using information in +the sky coordinate descriptor and the mwcs descriptor. + +.ih +NOTES +Note that the sk_saveim call does not include a call to the MWCS mw_saveim +routine. This call must be made separately. + +Type "help mwcs$MWCS.hlp fi+" to find out more about the IRAF image world +coordinate system code. +SEE ALSO +skdecwcs, skdecim +.endhelp diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/sksetd.hlp b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/sksetd.hlp new file mode 100644 index 00000000..f518d71c --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/sksetd.hlp @@ -0,0 +1,53 @@ +.help sksetd Mar00 Skywcs +.ih +NAME +sksetd -- set a double sky coordinate descriptor parameter +.ih +SYNOPSIS +include <skywcs.h> + +call sk_setd (coo, parameter, dval) + +.nf +pointer coo # the input sky coordinate descriptor +int parameter # the double parameter to be set +double dval # the value of the parameter to be set +.fi +.ih +ARGUMENTS +.ls coo +The sky coordinate descriptor. +.le +.ls parameter +The parameter to be set. The double parameter definitions in skywcs.h are: +.nf + S_VXOFF # the logical ra / longitude offset in pixels + S_VYOFF # the logical dec / latitude offset in pixels + S_VXSTEP # the logical ra / longitude step size in pixels + S_VYSTEP # the logical dec / latitude step size in pixels + S_EQUINOX # the equinox in years + S_EPOCH # the MJD of the observation +.fi +.le +.ls dval +The value of the parameter to be set. +.le +.ih +DESCRIPTION +Sk_setd sets the values of double sky coordinate descriptor parameters. +.ih +NOTES +The offsets and step sizes default to 0 and 1 for both axes. However +if the sky coordinate descriptor was derived from an input image section, e.g. +"dev$ypix[100:300,100:300]" these numbers may assume other values in some +circumstances. + +The equinox and epoch of observation are normally set by the calling program +when the sky coordinate descriptor is initialized, e.g. they default +to 2000.0 and 51544.50000 if the input coordinate system was "fk5". + +In most cases these parameters should not be set by the user. +.ih +SEE ALSO +skseti, sksets +.endhelp diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skseti.hlp b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skseti.hlp new file mode 100644 index 00000000..b08be476 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skseti.hlp @@ -0,0 +1,93 @@ +.help skseti Mar00 Skywcs +.ih +NAME +skseti -- set an integer sky coordinate descriptor parameter +.ih +SYNOPSIS +include <skywcs.h> + +call sk_seti (coo, parameter, ival) + +.nf +pointer coo # the input sky coordinate descriptor +int parameter # the integer parameter to be set +int ival # the value of the parameter to be set +.fi +.ih +ARGUMENTS +.ls coo +The sky coordinate descriptor. +.le +.ls parameter +The parameter to be set. The double parameter definitions in skywcs.h are: +.nf + S_CTYPE # the celestial coordinate system type + S_RADECSYS # the equatorial system type + S_NLNGUNITS # the ra / longitude units + S_NLATUNITS # the dec/ latitude units + S_WTYPE # the projection type + S_PLNGAX # the physical ra / longitude axis + S_PLATAX # the physical dec / latitude axis + S_XLAX # the logical ra / longitude axis + S_YLAX # the logical dec / latitude axis + S_PIXTYPE # the IRAF pixel coordinate system type + S_NLNGAX # the length of ra / longitude axis + S_NLATAX # the length of dec / latitude axis + S_STATUS # the coordinate system status +.fi +.le +.ls ival +The value of the parameter to be set. +.le +.ih +DESCRIPTION +Sk_seti sets the values of integer sky coordinate descriptor parameters. +.ih +NOTES +Permitted values of S_CTYPE are CTYPE_EQUATORIAL, CTYPE_ECLIPTIC, +CTYPE_GALACTIC, and CTYPE_SUPERGALACTIC. The corresponding string dictionary +is CTYPE_LIST. + +Permitted types of S_RADECSYS are EQTYPE_FK4, EQTYPE_FK4NOE, +EQTYPE_FK5, EQTYPE, ICRS, and EQTYPE_GAPPT. The corresponding string +dictionary is EQTYPE_LIST. + +Permitted values of S_WTYPE are WTYPE_LIN, WTYPE_AZP, WTYPE_TAN, WTYPE_SIN, +WTYPE_STG, WTYPE_ARC, WTYPE_ZPN, WTYPE_ZEA, WTYPE_AIR, WTYPE_CYP, WTYPE_CAR, +WTYPE_MER, WTYPE_CEA, WTYPE_COP, WTYPE_COD, WTYPE_COE, WTYPE_COO, WTYPE_BON, +WTYPE_PCO, WTYPE_GLS, WTYPE_PAR, WTYPE_AIT, WTYPE_MOL, WTYPE_CSC, WTYPE_QSC, +WTYPE_TSC, WTYPE_TNX, WTYPE_ZPX. The corresponding string dictionary is +WTYPE_LIST. + +Permitted values of S_PIXTYPE are PIXTYPE_LOGICAL, PIXTYPE_TV, +PIXTYPE_PHYSICAL. and PIXTPE_WORLD. The corresponding string dictionary +is PIXTYPE_LIST. + +Permitted values of S_NLNGUNITS are SKY_HOURS, SKY_DEGREES, and SKY_RADIANS. +The corresponding string dictionary is SKY_LNG_UNITLIST. +Permitted values of S_NLATUNITS are SKY_DEGREES, and SKY_RADIANS. +The corresponding string dictionary is SKY_LAT_UNITLIST. + +The parameters S_CTYPE, S_RADECSYS, S_NLNGUNITS, and S_NLATUNITS are +important for all sky coordinate descriptors regardless of the source. +The parameters S_WTYPE, S_PLNGAX, S_PLATAX, S_XLAX, S_YLAX, S_PIXTYPE, +S_NLNGAX, and S_NLATAX are only important for sky coordinate descriptors +derived from an image sky coordinate systems. S_STATUS is OK if the sky +coordinate descriptor describes a valid celestial coordinate system, ERR +otherwise. + +In most cases these parameters should not be modified by the user. The +major exceptions are the units parameters S_NLNGUNITS and N_LATUNITS +which assumes default values fo hours and degrees for equatorial sky +coordinate systems and degrees and degrees for other sky coordinate systems. +If the user input and output units are different from the normal defaults +then the units parameters should be set appropriately. + +Parameters that occasionally need to be reset when a coordinate system +is created, edited, or saved to an image are S_WTYPE, S_PIXTYPE, S_PLNGAX, +and S_PLATAX. + +.ih +SEE ALSO +sksetd, sksets +.endhelp diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/sksets.hlp b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/sksets.hlp new file mode 100644 index 00000000..8e4179b4 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/sksets.hlp @@ -0,0 +1,36 @@ +.help sksets Mar00 Skywcs +.ih +NAME +sksets -- set a string sky coordinate descriptor parameter +.ih +SYNOPSIS +include <skywcs.h> + +call sk_sets (coo, parameter, str) + +.nf +pointer coo # the input sky coordinate descriptor +int parameter # the string parameter to be set +char str # the value of the string parameter to be set +.fi +.ih +ARGUMENTS +.ls coo +The sky coordinate descriptor. +.le +.ls parameter +The parameter to be set. The string parameter definitions in skywcs.h are: +.nf + S_COOSYSTEM # the celestial coordinate system name +.fi +.le +.ls str +The value of the parameter to be set. +.le +.ih +DESCRIPTION +Sk_sets sets the values of string sky coordinate descriptor parameters. +.ih +SEE ALSO +sksetd, skseti +.endhelp diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skstatd.hlp b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skstatd.hlp new file mode 100644 index 00000000..52dc0c70 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skstatd.hlp @@ -0,0 +1,49 @@ +.help skstatd Mar00 Skywcs +.ih +NAME +skstatd -- get a double sky coordinate descriptor parameter +.ih +SYNOPSIS +include <skywcs.h> + +dval = sk_statd (coo, parameter) + +.nf +pointer coo # the input sky coordinate descriptor +int parameter # the double parameter to be returned +.fi +.ih +ARGUMENTS +.ls coo +The sky coordinate descriptor. +.le +.ls parameter +The oarameter to be returned. The double parameter definitions in skywcs.h are: +.nf + S_VXOFF # the logical ra / longitude offset in pixels + S_VYOFF # the logical dec / latitude offset in pixels + S_VXSTEP # the logical ra / longitude step size in pixels + S_VYSTEP # the logical dec / latitude step size in pixels + S_EQUINOX # the equinox in years + S_EPOCH # the MJD of the observation +.fi +.le +.ih +DESCRIPTION +Sk_statd returns the values of double sky coordinate descriptor parameters. + +.ih +NOTES +The offsets and step sizes default to 0 and 1 for both axes. However +if the sky coordinate descriptor was derived from an input image section, e.g. +"dev$ypix[100:300,100:300]" these numbers may assume other values in some +circumstances. + +The equinox and epoch of observation are normally set by the calling program +when the sky coordinate descriptor is initialized, e.g. they default +to 2000.0 and 51544.50000 if the input coordinate system was "fk5". + +.ih +SEE ALSO +skstati, skstats +.endhelp diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skstati.hlp b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skstati.hlp new file mode 100644 index 00000000..90d33eb1 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skstati.hlp @@ -0,0 +1,79 @@ +.help skstati Mar00 Skywcs +.ih +NAME +skstati -- get an integer sky coordinate descriptor parameter +.ih +SYNOPSIS +include <skywcs.h> + +ival = sk_stati (coo, parameter) + +.nf +pointer coo # the input sky coordinate descriptor +int parameter # the integer parameter to be returned +.fi +.ih +ARGUMENTS +.ls coo +The sky coordinate descriptor. +.le +.ls parameter +Parameter to be returned. The integer parameter definitions in skywcs.h are: +.nf + S_CTYPE # the celestial coordinate system type + S_RADECSYS # the equatorial system type + S_NLNGUNITS # the ra / longitude units + S_NLATUNITS # the dec/ latitude units + S_WTYPE # the projection type + S_PLNGAX # the physical ra / longitude axis + S_PLATAX # the physical dec / latitude axis + S_XLAX # the logical ra / longitude axis + S_YLAX # the logical dec / latitude axis + S_PIXTYPE # the IRAF pixel coordinate system type + S_NLNGAX # the length of the ra / longitude axis + S_NLATAX # the length of the dec / latitude axis + S_STATUS # the coordinate system status +.fi +.le +.ih +DESCRIPTION +Sk_stati returns the values of integer sky coordinate descriptor parameters. + +.ih +NOTES +Permitted values of S_CTYPE are CTYPE_EQUATORIAL, CTYPE_ECLIPTIC, +CTYPE_GALACTIC, and CTYPE_SUPERGALACTIC. The corresponding string dictionary +is CTYPE_LIST. + +Permitted types of S_RADECSYS are EQTYPE_FK4, EQTYPE_FK4NOE, +EQTYPE_FK5, EQTYPE, ICRS, and EQTYPE_GAPPT. The corresponding string +dictionary is EQTYPE_LIST. + +Permitted values of S_WTYPE are WTYPE_LIN, WTYPE_AZP, WTYPE_TAN, WTYPE_SIN, +WTYPE_STG, WTYPE_ARC, WTYPE_ZPN, WTYPE_ZEA, WTYPE_AIR, WTYPE_CYP, WTYPE_CAR, +WTYPE_MER, WTYPE_CEA, WTYPE_COP, WTYPE_COD, WTYPE_COE, WTYPE_COO, WTYPE_BON, +WTYPE_PCO, WTYPE_GLS, WTYPE_PAR, WTYPE_AIT, WTYPE_MOL, WTYPE_CSC, WTYPE_QSC, +WTYPE_TSC, WTYPE_TNX, WTYPE_ZPX. The corresponding string dictionary is +WTYPE_LIST. + +Permitted values of S_PIXTYPE are PIXTYPE_LOGICAL, PIXTYPE_TV, +PIXTYPE_PHYSICAL. and PIXTPE_WORLD. The corresponding string dictionary +is PIXTYPE_LIST. + +Permitted values of S_NLNGUNITS are SKY_HOURS, SKY_DEGREES, and SKY_RADIANS. +The corresponding string dictionary is SKY_LNG_UNITLIST. +Permitted values of S_NLATUNITS are SKY_DEGREES, and SKY_RADIANS. +The corresponding string dictionary is SKY_LAT_UNITLIST. + +The parameters S_CTYPE, S_RADECSYS, S_NLNGUNITS, and S_NLATUNITS are +important for all sky coordinate descriptors regardless of the source. +The parameters S_WTYPE, S_PLNGAX, S_PLATAX, S_XLAX, S_YLAX, S_PIXTYPE, +S_NLNGAX, and S_NLATAX are only important for sky coordinate descriptors +derived from an image sky coordinate systems. S_STATUS is OK if the sky +coordinate descriptor describes a valid celestial coordinate system, ERR +otherwise. + +.ih +SEE ALSO +skstatd, skstats +.endhelp diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skstats.hlp b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skstats.hlp new file mode 100644 index 00000000..483ed3e5 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skstats.hlp @@ -0,0 +1,40 @@ +.help skstats Mar00 Skywcs +.ih +NAME +skstats -- get a string sky coordinate descriptor parameter +.ih +SYNOPSIS +include <skywcs.h> + +call sk_stats (coo, parameter, str, maxch) + +.nf +pointer coo # the input sky coordinate descriptor +int parameter # the string parameter to be returned +char str # the returned string parameter value +int maxch # the maximum size of the returned string parameter +.fi +.ih +ARGUMENTS +.ls coo +The sky coordinate descriptor. +.le +.ls parameter +The parameter to be returned. The string parameter definitions in skywcs.h are: +.nf + S_COOSYSTEM # the celestial coordinate system name +.fi +.le +.ls str +The value of the returned string. +.le +.ls maxch +The maximum size of the returned string. +.le +.ih +DESCRIPTION +Sk_stats returns the values of string sky coordinate descriptor parameters. +.ih +SEE ALSO +skstati, skstatd +.endhelp diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skultran.hlp b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skultran.hlp new file mode 100644 index 00000000..417eaba6 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skultran.hlp @@ -0,0 +1,51 @@ +.help skultran Mar00 Skywcs +.ih +NAME +skultran -- transform between coordinate systems +.ih +SYNOPSIS +call sk_ultran (incoo, outcoo, ilng, ilat, olng, olat, npts) + +.nf +pointer incoo # the input sky coordinate descriptor +pointer outcoo # the output sky coordinate descriptor +double ilng, ilat # the input celestial coordinates in expected units +double olng, olat # the output celestial coordinates in expected units +int npts # the number of input and output coordinate pairs +.fi +.ih +ARGUMENTS +.ls incoo +The input sky coordinate descriptor. +.le +.ls parameter +.ls outcoo +The output sky coordinate descriptor. +.le +.ls ilng, ilat +The input sky coordinates in the units defined by the integer parameters +S_NLNGUNITS and S_NLATUNITS. +.le +.ls olng, olat +The output sky coordinates in the units defined by the integer parameters +S_NLNGUNITS and S_NLATUNITS. +.le +.ls npts +The number of input and output coordinate pairs. +.le +.ih +DESCRIPTION +The coordinates in the input coordinate system are converted to +coordinates in the output coordinates system. + +If the calling program has not set the S_NLNGUNITS and S_NLATUNITS parameters +in either system the expected coordinates are hours and degrees for +equatorial sky coordinate systems and degrees and degrees for other sky +coordinate systems. The calling program must either perform the necessary +coordinate conversions or set the units parameters in the input and output +sky coordinate descriptors appropriately. + +.ih +SEE ALSO +sk_lltran, sk_equatorial +.endhelp diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skywcs.hd b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skywcs.hd new file mode 100644 index 00000000..74bac140 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skywcs.hd @@ -0,0 +1,25 @@ +# Help directory for the SKYWCS library + +$doc = "./" +$source = "../" + +skdecwcs hlp=doc$skdecwcs.hlp, src=source$skdecode.x +skdecwstr hlp=doc$skdecwstr.hlp, src=source$skdecode.x +skdecim hlp=doc$skdecim.hlp, src=source$skdecode.x +skenwcs hlp=doc$skenwcs.hlp, src=source$skdecode.x +skcopy hlp=doc$skcopy.hlp, src=source$skdecode.x +skiiprint hlp=doc$skiiprint.hlp, src=source$skwrite.x +skiiwrite hlp=doc$skiiwrite.hlp, src=source$skwrite.x +skstati hlp=doc$skstati.hlp, src=source$skstat.x +skstatd hlp=doc$skstatd.hlp, src=source$skstat.x +skstats hlp=doc$skstats.hlp, src=source$skstat.x +skseti hlp=doc$skseti.hlp, src=source$skset.x +sksetd hlp=doc$sksetd.hlp, src=source$skset.x +sksets hlp=doc$sksets.hlp, src=source$skset.x +skultran hlp=doc$skultran.hlp, src=source$skytransform.x +sklltran hlp=doc$sklltran.hlp, src=source$skytransform.x +skequatorial hlp=doc$skequatorial.hlp, src=source$skytransform.x +sksaveim hlp=doc$sksaveim.hlp, src=source$sksaveim.x +skclose hlp=doc$skclose.hlp, src=source$skdecode.x + +ccsystems hlp=doc$ccsystems.hlp diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skywcs.hlp b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skywcs.hlp new file mode 100644 index 00000000..498f9b43 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skywcs.hlp @@ -0,0 +1,306 @@ +.help skywcs Oct00 xtools +.ih +NAME +skywcs -- sky coordinates package +.ih +SYNOPSIS + +.nf + stat = sk_decwcs (ccsystem, mw, coo, imcoo) + stat = sk_decwstr (ccsystem, coo, imcoo) + stat = sk_decim (im, wcs, mw, coo) + sk_enwcs (coo, ccsystem, maxch) + newcoo = sk_copy (coo) + sk_iiprint (label, imagesys, mw, coo) + sk_iiwrite (fd, label, imagesys, mw, coo) +[id]val = sk_stat[id] (coo, param) + sk_stats (coo, param, str, maxch) + sk_set[id] (coo, param, [id]val) + sk_sets (coo, param, str) + sk_ultran (incoo, outcoo, ilng, ilat, olng, olat, npts) + sk_lltran (incoo, outoo, ilng, ilat, ipmlng, ipmlat, px, rv, + olng, olat) + sk_equatorial (incoo, outcoo, ilng, ilat, ipmlng, ipmlat, px, + rv, olng, olat) + sk_saveim (coo, mw, im) + sk_close (coo) + +.fi +.ih +DESCRIPTION + +The skywcs package contains a simple set of routines for doing managing +sky coordinate information and for transforming from one sky coordinate +system to another. The sky coordinate system is defined either by a system +name, e.g. "J2000", "galactic, etc. or by an image system name, e.g. +"dev$ypix" or "dev$ypix world". + +The skywcs routine are layered on the Starlink Positional Astronomy library +SLALIB which is installed in the IRAF MATH package. Type "help slalib +option=sys" for more information about SLALIB. + + +.ih +NOTES + +An "include <skywcs.h>" statement must be included in the calling program +to make the skywcs package parameter definitions visible to the calling +program. + +The sky coordinate descriptor is created with a call to one of the sk_decwcs +sk_decwstr or sk_imwcs routines. If the source of sky coordinate descriptor +is an image then an IRAF MWCS descriptor will be returned with the sky +oordinate descriptor. The sky coordinate descriptor is freed with a +call to sk_close. A separate call to mw_close must be made to free the +MWCS descriptor if one was allocated. + +By default the main skywcs coordinate transformation routine sk_ultran +assumes that the input and output sky coordinates are in hours and degrees +if the input and output coordinate systems are equatorial, otherwise the +coordinates are assumed to be in degrees and degrees. The default input and +output sky coordinate units can be reset with calls to sk_seti. Two lower level +coordinate transformations for handling proper motions sk_lltran and +sk_equatorial are also available. These routines that the input and output +coordinates and proper motions are in radians. + +Calling programs working with both sky coordinate and MWCS descriptors +need to be aware that the MWCS routines assume that all sky coordinates +must be input in degrees and will be output in degrees and adjust their +code accordingly. + +The skywcs routine sk_saveim can be used to update an image header. + + +.ih +EXAMPLES +.nf +Example 1: Convert from B1950 coordinates to J2000 coordinates. + + include <skywcs.h> + + .... + + # Open input coordinate system. + instat = sk_decwstr ("B1950", incoo, NULL) + if (instat == ERR) { + call sk_close (incoo) + return + } + + # Open output coordinate system. + outstat = sk_decwstr ("J2000", outcoo, NULL) + if (outstat == ERR) { + call sk_close (outcoo) + return + } + + # Do the transformation assuming the input coordinates are in hours + # and degrees. The output coordinates will be in hours and degrees + # as well. + call sk_ultran (incoo, outcoo, rain, decin, raout, decout, npts) + + # Close the coordinate descriptors. + call sk_close (incoo) + call sk_close (outcoo) + + ... + + +Example 2: Repeat example 1 but convert to galactic coordinates. + + include <skywcs.h> + + .... + + # Open the input coordinate system. + instat = sk_decwstr ("B1950", incoo, NULL) + if (instat == ERR) { + call sk_close (incoo) + return + } + + # Open the output coordinate system. + outstat = sk_decwstr ("galactic", outcoo, NULL) + if (outstat == ERR) { + call sk_close (outcoo) + return + } + + # Dd the transformation assuming the input coordinates are in hours and + # degrees. The output coordinates will be in degrees and degrees. + call sk_ultran (incoo, outcoo, rain, decin, raout, decout, npts) + + # Close the coordinate descriptors. + call sk_close (incoo) + call sk_close (outcoo) + + ... + +Example 3: Convert a grid of pixel coordinates in the input image to the + equivalent pixel coordinate in the output image using the + image world coordinate systems to connect the two. + + include <skywcs.h> + + .... + + # Mwref will be defined because the input system is an image. + refstat = sk_decwcs ("refimage logical", mwref, refcoo, NULL) + if (refstat == ERR || mwref == NULL) { + if (mwref != NULL) + call mw_close (mwref) + call sk_close (refcoo) + return + } + + # Set the reference coordinate descriptor so it expects input in degrees + # and degrees. + call sk_seti (refcoo, S_NLNGUNUTS, SKY_DEGREES) + call sk_seti (refcoo, S_NLATUNUTS, SKY_DEGREES) + + # Mwout will be defined because the output system is an image. + outstat = sk_decwcs ("image logical", mwout, outcoo, NULL) + if (outstat == ERR || mwout == NULL) { + if (mwout != NULL) + call mw_close (mwout) + call sk_close (outcoo) + call mw_close (mwref) + call sk_close (refcoo) + return + } + + # Set the output coordinate descriptor so it will output coordinates + # in degrees and degrees. + call sk_seti (outcoo, S_NLNGUNUTS, SKY_DEGREES) + call sk_seti (outcoo, S_NLATUNUTS, SKY_DEGREES) + + # Compute pixel grid in refimage and store coordinate in the arrays + # xref and yref. + npts = 0 + do j = 1, IM_LEN(im,2), 100 { + do i = 1, IM_LEN(im,1), 100 { + npts = npts + 1 + xref[npts] = i + yref[npts] = j + } + } + + # Convert xref and yref to celestial coordinates raref and decref using + # mwref. The output coordinates will be in degrees and degrees. + ctref = mw_sctran (mwref, "logical", "world", 03B) + do i = 1, npts + call mw_c2trand (ctref, xref[i], yref[i], raref[i], decref[i]) + call ct_free (ctref) + + # Convert the reference celestial coordinates to the output celestial + # coordinate system using the coordinate descriptors. + call sk_ultran (refcoo, outcoo, raref, decref, raout, decout, npts) + + # Convert the output celestial coordinates to pixel coordinates in + # the other image using mwout. + ctout = mw_sctran (mwout, "world", "logical", 03B) + do i = 1, npts + call mw_c2trand (ctout, raout[i], decout[i], xout[i], yout[i]) + call ct_free (ctout) + + # Print the input and output pixel coordinates. + do i = 1, npts { + call printf ("%10.3f %10.3f %10.3f %10.3f\n") + call pargd (xref[i]) + call pargd (yref[i]) + call pargd (xout[i]) + call pargd (yout[i]) + } + + # Tidy up. + call mw_close (mwref) + call mw_close (mwout) + call sk_close (refcoo) + call sk_close (outcoo) + + +Example 4: Convert a 2D image with an J2000 tangent plane projection + wcs to the equivalent galactic wcs. The transformation + requires a shift in origin and a rotation. Assume that the ra + axis is 1 and the dec axis is 2. The details of how to compute + the rotation are not shown here. See the + imcctran task for details. + + include <mwset.h> + include <skywcs.h> + + ... + + # Open image. + im = immap (image, READ_WRITE, 0) + + # Open the image coordinate system. + instat = sk_decim (im, "logical", mwin, cooin) + if (instat == ERR || mwin == NULL) { + ... + call sk_close (cooin) + ... + } + + # Get the dimensions of the mwcs descriptor. This should be 2. + ndim = mw_ndim (mwin, MW_NPHYSDIM) + + # Get the default coordinates to degrees and degreees. + call sk_seti (cooin, S_NLNGUNITS, SKY_DEGREES) + call sk_seti (cooin, S_NATGUNITS, SKY_DEGREES) + + # Open the output coordinate system. Mwout is NULL because this system + # is not an image. + outstat = sk_decwstr ("galactic", mwout, cooout, cooin) + if (outstat == ERR) { + ... + call sk_close (outstat) + ... + } + + # Make a copy of the mwcs descriptor. + mwout = mw_newcopy (mwin) + + # Allocate space for the r and w vectors and cd matrix. + call malloc (r, ndim, TY_DOUBLE) + call malloc (w, ndim, TY_DOUBLE) + call malloc (cd, ndim * ndim, TY_DOUBLE) + call malloc (newcd, ndim * ndim, TY_DOUBLE) + + # Assume for simplicty that the MWCS LTERM is the identify transform. + # so we don't have to worry about it. Get the WTERM which consists + # of r the reference point in pixels, w the reference point in degrees, + # and the cd matrix in degrees per pixel. + call mw_gwtermd (mwin, Memd[r], Memd[w], Memd[cd], ndim) + + # Convert the world coordinates zero point. The pixel zero point + # remains the same. + tilng = Memd[w] + tilat = Memd[w+1] + call sk_ultran (incoo, outcoo, tilng, tilat, tolng, tolat, 1) + Memd[w] = tolng + Memd[w+1] = tolat + + # Figure out how much to rotate the coordinate system and edit the + # compute a new CD matrix. Call it newcd. + ... + + # Enter the new CD matrix and zero point. + call mw_swterm (mwout, Memd[r], Memd[w], Memd[newcd], ndim) + + # Update the header. + call sk_saveim (cooout, mwout, im) + call mw_saveim (mwout, im) + ... + + # Tidy up. + call mfree (r, TY_DOUBLE) + call mfree (w, TY_DOUBLE) + call mfree (cd, TY_DOUBLE) + call mfree (newcd, TY_DOUBLE) + call mw_close (mwin) + call mw_close (mwout) + call sk_close (cooin) + call sk_close (cooout) + call imunmap (im) +.fi diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skywcs.men b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skywcs.men new file mode 100644 index 00000000..9eecc277 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skywcs.men @@ -0,0 +1,15 @@ + skdecwcs - Open a sky coordinate descriptor usning an image or system name + skdecwstr - Open a sky coordinate descriptor using a system name + skdecim - Open a sky coordinate descriptor using an image descriptor + skenwcs - Encode a system name using a sky coordinate descriptor + skcopy - Copy a sky coordinate descriptor + skstat[ids] - Get a sky coordinate descriptor parameter value + skset[ids] - Set a sky coordinate descriptor parameter value + skiiprint - Print a sky coordinate descriptor summary + skiiwrite - Write a sky coordinate descriptor summary + skultran - Transform between coordinate systems + sklltran - Apply pm and transform between coordinates systems +skequatorial - Apply pm and transform between equatorial coordinate systems + sksaveim - Update image header using sky coordinate descriptor + skclose - Close the sky coordinate descriptor + ccsystems - Describe the supported celestial coordinate systems diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/mkpkg b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/mkpkg new file mode 100644 index 00000000..ad049271 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/mkpkg @@ -0,0 +1,16 @@ +# Libary for the celestial coordinate sytem pacakge + +$checkout libpkg.a ../../ +$update libpkg.a +$checkin libpkg.a ../../ +$exit + +libpkg.a: + skdecode.x <imio.h> <imhdr.h> <mwset.h> skywcsdef.h skywcs.h + skwrite.x skywcsdef.h skywcs.h + skstat.x skywcsdef.h skywcs.h + skset.x skywcsdef.h skywcs.h + sktransform.x <math.h> skywcsdef.h skywcs.h + sksaveim.x skywcsdef.h skywcs.h + skwrdstr.x + ; diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skdecode.f b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skdecode.f new file mode 100644 index 00000000..03e49f1b --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skdecode.f @@ -0,0 +1,1412 @@ + integer function skdecs (instr, mw, coo, imcoo) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer mw + integer coo + integer imcoo + integer*2 instr(*) + integer stat + integer sp + integer str1 + integer str2 + integer laxno + integer paxval + integer im + integer skstrs + integer skdecm + integer immap + logical xerpop + logical xerflg + common /xercom/ xerflg + integer sw0001 + save + call xcallc(coo, (30 + 255 + 1), 10 ) + call xstrcy(instr, memc((((coo+25)-1)*2+1)) , 255 ) + call smark (sp) + call salloc (str1, 1023 , 2) + call salloc (str2, 1023 , 2) + call salloc (laxno, 7 , 4) + call salloc (paxval, 7 , 4) + call sscan (instr) + call gargwd (memc(str1), 1023 ) + call gargwd (memc(str2), 1023 ) + call xerpsh + im = immap (memc(str1), 1 , 0) + if (xerflg) goto 112 +112 if (.not.xerpop()) goto 110 + mw = 0 + if (.not.(imcoo .eq. 0)) goto 120 + memi(coo+20) = 2048 + memi(coo+21) = 2048 + memi(coo+15) = 1 + memi(coo+16) = 2 + memi(coo+17) = 1 + memi(coo+18) = 2 + memd((((coo)-1)/2+1)) = 0.0d0 + memd((((coo+2)-1)/2+1)) = 0.0d0 + memd((((coo+4)-1)/2+1)) = 1.0d0 + memd((((coo+6)-1)/2+1)) = 1.0d0 + memi(coo+14) = 0 + goto 121 +120 continue + memi(coo+20) = memi(imcoo+20) + memi(coo+21) = memi(imcoo+21) + memi(coo+15) = memi(imcoo+15) + memi(coo+16) = memi(imcoo+16) + memi(coo+17) = memi(imcoo+17) + memi(coo+18) = memi(imcoo+18) + memd((((coo)-1)/2+1)) = memd((((imcoo)-1)/2+1)) + memd((((coo+2)-1)/2+1)) = memd((((imcoo+2)-1)/2+1)) + memd((((coo+4)-1)/2+1)) = memd((((imcoo+4)-1)/2+1)) + memd((((coo+6)-1)/2+1)) = memd((((imcoo+6)-1)/2+1)) + memi(coo+14) = memi(imcoo+14) +121 continue + memi(coo+19) = 4 + stat = skstrs (instr, memi(coo+12) , memi(coo+13) , memd(((( + * coo+8)-1)/2+1)) , memd((((coo+10)-1)/2+1)) ) + sw0001=(memi(coo+12) ) + goto 130 +140 continue + memi(coo+22) = 3 + memi(coo+23) = 1 + goto 131 +150 continue + memi(coo+22) = 1 + memi(coo+23) = 1 + goto 131 +130 continue + if (sw0001.eq.1) goto 140 + goto 150 +131 continue + goto 111 +110 continue + stat = skdecm (im, memc(str2), mw, coo) + call imunmp (im) +111 continue + call sfree (sp) + memi(coo+24) = stat + skdecs = (stat) + goto 100 +100 return + end + integer function skdecr (instr, coo, imcoo) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer coo + integer imcoo + integer*2 instr(*) + integer stat + integer skstrs + integer sw0001 + save + call xcallc(coo, (30 + 255 + 1), 10 ) + call xstrcy(instr, memc((((coo+25)-1)*2+1)) , 255 ) + if (.not.(imcoo .eq. 0)) goto 110 + memi(coo+20) = 2048 + memi(coo+21) = 2048 + memi(coo+15) = 1 + memi(coo+16) = 2 + memi(coo+17) = 1 + memi(coo+18) = 2 + memd((((coo)-1)/2+1)) = 0.0d0 + memd((((coo+2)-1)/2+1)) = 0.0d0 + memd((((coo+4)-1)/2+1)) = 1.0d0 + memd((((coo+6)-1)/2+1)) = 1.0d0 + memi(coo+14) = 0 + goto 111 +110 continue + memi(coo+20) = memi(imcoo+20) + memi(coo+21) = memi(imcoo+21) + memi(coo+15) = memi(imcoo+15) + memi(coo+16) = memi(imcoo+16) + memi(coo+17) = memi(imcoo+17) + memi(coo+18) = memi(imcoo+18) + memd((((coo)-1)/2+1)) = memd((((imcoo)-1)/2+1)) + memd((((coo+2)-1)/2+1)) = memd((((imcoo+2)-1)/2+1)) + memd((((coo+4)-1)/2+1)) = memd((((imcoo+4)-1)/2+1)) + memd((((coo+6)-1)/2+1)) = memd((((imcoo+6)-1)/2+1)) + memi(coo+14) = memi(imcoo+14) +111 continue + memi(coo+19) = 4 + stat = skstrs (instr, memi(coo+12) , memi(coo+13) , memd((((coo + * +8)-1)/2+1)) , memd((((coo+10)-1)/2+1)) ) + sw0001=(memi(coo+12) ) + goto 120 +130 continue + memi(coo+22) = 3 + memi(coo+23) = 1 + goto 121 +140 continue + memi(coo+22) = 1 + memi(coo+23) = 1 + goto 121 +120 continue + if (sw0001.eq.1) goto 130 + goto 140 +121 continue + memi(coo+24) = stat + skdecr = (stat) + goto 100 +100 return + end + integer function skdecm (im, wcs, mw, coo) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer im + integer mw + integer coo + integer*2 wcs(*) + integer stat + integer sp + integer str1 + integer laxno + integer paxval + integer skimws + integer strdic + integer mwstai + integer mwopem + logical xerpop + logical xerflg + common /xercom/ xerflg + integer sw0001 + integer*2 st0001(6) + integer*2 st0002(28) + save + integer iyy + data st0001 / 37,115, 32, 37,115, 0/ + data (st0002(iyy),iyy= 1, 8) /124,108,111,103,105, 99, 97,108/ + data (st0002(iyy),iyy= 9,16) /124,116,118,124,112,104,121,115/ + data (st0002(iyy),iyy=17,24) /105, 99, 97,108,124,119,111,114/ + data (st0002(iyy),iyy=25,28) /108,100,124, 0/ + call xmallc(coo, (30 + 255 + 1), 10 ) + call sprinf (memc((((coo+25)-1)*2+1)) , 255 , st0001) + call pargsr (memc((((im+200 +165)-1)*2+1)) ) + call pargsr (wcs) + call smark (sp) + call salloc (str1, 1023 , 2) + call salloc (laxno, 7 , 4) + call salloc (paxval, 7 , 4) + call xerpsh + mw = mwopem (im) + if (xerflg) goto 112 +112 if (.not.xerpop()) goto 110 + memi(coo+12) = 0 + memi(coo+13) = 0 + memd((((coo+8)-1)/2+1)) = 1.6d308 + memd((((coo+10)-1)/2+1)) = 1.6d308 + mw = 0 + memi(coo+15) = 1 + memi(coo+16) = 2 + memi(coo+17) = 1 + memi(coo+18) = 2 + memi(coo+20) = 2048 + memi(coo+21) = 2048 + memd((((coo)-1)/2+1)) = 0.0d0 + memd((((coo+2)-1)/2+1)) = 0.0d0 + memd((((coo+4)-1)/2+1)) = 1.0d0 + memd((((coo+6)-1)/2+1)) = 1.0d0 + memi(coo+14) = 0 + memi(coo+19) = 1 + memi(coo+22) = 1 + memi(coo+23) = 1 + stat = -1 + goto 111 +110 continue + memi(coo+19) = strdic (wcs, memc(str1), 1023 , st0002) + if (.not.(memi(coo+19) .le. 0)) goto 120 + memi(coo+19) = 1 +120 continue + if (.not.(skimws (im, mw, memi(coo+12) , memi(coo+15) , memi + * (coo+16) , memi(coo+14) , memi(coo+13) , memd((((coo+8)-1)/2 + * +1)) , memd((((coo+10)-1)/2+1)) ) .eq. 0)) goto 130 + sw0001=(memi(coo+12) ) + goto 140 +150 continue + memi(coo+22) = 3 + memi(coo+23) = 1 + goto 141 +160 continue + memi(coo+22) = 1 + memi(coo+23) = 1 + goto 141 +140 continue + if (sw0001.eq.1) goto 150 + goto 160 +141 continue + call mwgaxp (mw, memi(laxno), memi(paxval), mwstai(mw, 5 + * )) + if (.not.(memi(laxno+memi(coo+15) -1) .lt. memi(laxno+ + * memi(coo+16) -1))) goto 170 + memi(coo+17) = memi(laxno+memi(coo+15) -1) + memi(coo+18) = memi(laxno+memi(coo+16) -1) + goto 171 +170 continue + memi(coo+17) = memi(laxno+memi(coo+16) -1) + memi(coo+18) = memi(laxno+memi(coo+15) -1) +171 continue + if (.not.(memi(coo+17) .le. 0 .or. memi(coo+18) .le. 0)) + * goto 180 + memd((((coo)-1)/2+1)) = 0.0d0 + memd((((coo+2)-1)/2+1)) = 0.0d0 + memd((((coo+4)-1)/2+1)) = 1.0d0 + memd((((coo+6)-1)/2+1)) = 1.0d0 + memi(coo+20) = 2048 + memi(coo+21) = 2048 + stat = -1 + goto 181 +180 continue + memd((((coo)-1)/2+1)) = meml(im+memi(im+memi(coo+17) + + * 47-1) +54-1) + memd((((coo+2)-1)/2+1)) = meml(im+memi(im+memi(coo+18) + * +47-1) +54-1) + memd((((coo+4)-1)/2+1)) = memi(im+memi(coo+17) +59-1) + memd((((coo+6)-1)/2+1)) = memi(im+memi(coo+18) +59-1) + memi(coo+20) = meml(im+200 +memi(coo+17) +8-1) + memi(coo+21) = meml(im+200 +memi(coo+18) +8-1) + stat = 0 +181 continue + goto 131 +130 continue + call mwcloe (mw) + mw = 0 + memi(coo+17) = 1 + memi(coo+18) = 2 + memi(coo+20) = 2048 + memi(coo+21) = 2048 + memd((((coo)-1)/2+1)) = 0.0d0 + memd((((coo+2)-1)/2+1)) = 0.0d0 + memd((((coo+4)-1)/2+1)) = 1.0d0 + memd((((coo+6)-1)/2+1)) = 1.0d0 + memi(coo+22) = 1 + memi(coo+23) = 1 + stat = -1 +131 continue +111 continue + call sfree (sp) + memi(coo+24) = stat + skdecm = (stat) + goto 100 +100 return + end + integer function skstrs (instr, ctype, radecs, equinx, epoch) + integer ctype + integer radecs + double precision equinx + double precision epoch + integer*2 instr(*) + integer ip + integer nitems + integer sctype + integer srades + integer stat + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer sp + integer str1 + integer str2 + integer strdic + integer nscan + integer ctod + double precision slej2d + double precision slepb + double precision sleb2d + double precision slepj + integer sw0001,sw0002,sw0003 + integer*2 st0001(63) + save + integer iyy + data (st0001(iyy),iyy= 1, 8) /124,102,107, 52,124,110,111,101/ + data (st0001(iyy),iyy= 9,16) /102,107, 52,124,102,107, 53,124/ + data (st0001(iyy),iyy=17,24) /105, 99,114,115,124, 97,112,112/ + data (st0001(iyy),iyy=25,32) / 97,114,101,110,116,124,101, 99/ + data (st0001(iyy),iyy=33,40) /108,105,112,116,105, 99,124,103/ + data (st0001(iyy),iyy=41,48) / 97,108, 97, 99,116,105, 99,124/ + data (st0001(iyy),iyy=49,56) /115,117,112,101,114,103, 97,108/ + data (st0001(iyy),iyy=57,63) / 97, 99,116,105, 99,124, 0/ + ctype = 0 + radecs = 0 + equinx = 1.6d308 + epoch = 1.6d308 + call smark (sp) + call salloc (str1, 1023 , 2) + call salloc (str2, 1023 , 2) + call sscan (instr) + call gargwd (memc(str1), 1023 ) + if (.not.(memc(str1) .eq. 0 .or. nscan() .lt. 1)) goto 110 + call sfree (sp) + skstrs = (-1) + goto 100 +110 continue + nitems = 1 +111 continue + sctype = strdic (memc(str1), memc(str2), 1023 , st0001) + if (.not.(sctype .le. 0)) goto 120 + ctype = 1 + goto 121 +120 continue + sw0001=(sctype) + goto 130 +140 continue + ctype = 1 + radecs = 1 + goto 131 +150 continue + ctype = 1 + radecs = 2 + goto 131 +160 continue + ctype = 1 + radecs = 3 + goto 131 +170 continue + ctype = 1 + radecs = 4 + goto 131 +180 continue + ctype = 1 + radecs = 5 + goto 131 +190 continue + ctype = 2 + goto 131 +200 continue + ctype = 3 + goto 131 +210 continue + ctype = 4 + goto 131 +130 continue + if (sw0001.lt.1.or.sw0001.gt.8) goto 131 + goto (140,150,160,170,180,190,200,210),sw0001 +131 continue + call gargwd (memc(str1), 1023 ) + if (.not.(nscan() .gt. nitems)) goto 220 + nitems = nitems + 1 +220 continue +121 continue + sctype = ctype + srades = radecs + sw0002=(sctype) + goto 230 +240 continue + sw0003=(srades) + goto 250 +260 continue + if (.not.(memc(str1) .eq. 74 .or. memc(str1) .eq. 106 .or + * . memc(str1) .eq. 66 .or. memc(str1) .eq. 98)) goto 270 + ip = 2 + goto 271 +270 continue + ip = 1 +271 continue + if (.not.(ctod (memc(str1), ip, equinx) .le. 0)) goto 280 + equinx = 1950.0d0 +280 continue + if (.not.(memc(str1) .eq. 74 .or. memc(str1) .eq. 106)) + * goto 290 + equinx = slepb (slej2d (equinx)) +290 continue + call gargwd (memc(str2), 1023 ) + if (.not.(nscan() .le. nitems)) goto 300 + epoch = sleb2d (equinx) + goto 301 +300 continue + if (.not.(memc(str2) .eq. 74 .or. memc(str2) .eq. 106 + * .or. memc(str2) .eq. 66 .or. memc(str2) .eq. 98)) goto + * 310 + ip = 2 + goto 311 +310 continue + ip = 1 +311 continue + if (.not.(ctod (memc(str2), ip, epoch) .le. 0)) goto + * 320 + epoch = sleb2d (equinx) + goto 321 +320 continue + if (.not.(epoch .le. 3000.0d0 .and. (memc(str2) .eq. + * 74 .or. memc(str2) .eq. 106))) goto 330 + epoch = slej2d (epoch) + goto 331 +330 continue + if (.not.(epoch .gt. 3000.0d0)) goto 340 + epoch = epoch - 2400000.5d0 + goto 341 +340 continue + epoch = sleb2d (epoch) +341 continue +331 continue +321 continue +301 continue + goto 251 +350 continue + if (.not.(memc(str1) .eq. 74 .or. memc(str1) .eq. 106 .or + * . memc(str1) .eq. 66 .or. memc(str1) .eq. 98)) goto 360 + ip = 2 + goto 361 +360 continue + ip = 1 +361 continue + if (.not.(ctod (memc(str1), ip, equinx) .le. 0)) goto 370 + equinx = 2000.0d0 +370 continue + if (.not.(memc(str1) .eq. 66 .or. memc(str1) .eq. 98)) + * goto 380 + equinx = slepj(sleb2d (equinx)) +380 continue + call gargwd (memc(str2), 1023 ) + if (.not.(nscan() .le. nitems)) goto 390 + epoch = slej2d (equinx) + goto 391 +390 continue + if (.not.(memc(str2) .eq. 74 .or. memc(str2) .eq. 106 + * .or. memc(str2) .eq. 66 .or. memc(str2) .eq. 98)) goto + * 400 + ip = 2 + goto 401 +400 continue + ip = 1 +401 continue + if (.not.(ctod (memc(str2), ip, epoch) .le. 0)) goto + * 410 + epoch = slej2d (equinx) + goto 411 +410 continue + if (.not.(epoch .le. 3000.0d0 .and. (memc(str2) .eq. + * 66 .or. memc(str2) .eq. 98))) goto 420 + epoch = sleb2d (epoch) + goto 421 +420 continue + if (.not.(epoch .gt. 3000.0d0)) goto 430 + epoch = epoch - 2400000.5d0 + goto 431 +430 continue + epoch = slej2d (epoch) +431 continue +421 continue +411 continue +391 continue + goto 251 +440 continue + equinx = 2000.0d0 + if (.not.(memc(str1) .eq. 74 .or. memc(str1) .eq. 106 .or + * . memc(str1) .eq. 66 .or. memc(str1) .eq. 98)) goto 450 + ip = 2 + goto 451 +450 continue + ip = 1 +451 continue + if (.not.(ctod (memc(str1), ip, epoch) .le. 0)) goto 460 + epoch = 1.6d308 + goto 461 +460 continue + if (.not.(epoch .le. 3000.0d0)) goto 470 + if (.not.(memc(str1) .eq. 66 .or. memc(str1) .eq. 98)) + * goto 480 + epoch = sleb2d (epoch) + goto 481 +480 continue + if (.not.(memc(str1) .eq. 74 .or. memc(str1) .eq. 106) + * ) goto 490 + epoch = slej2d (epoch) + goto 491 +490 continue + if (.not.(epoch .lt. 1984.0d0)) goto 500 + epoch = sleb2d (epoch) + goto 501 +500 continue + epoch = slej2d (epoch) +501 continue +491 continue +481 continue + goto 471 +470 continue + epoch = epoch - 2400000.5d0 +471 continue +461 continue + goto 251 +510 continue + ip = 1 + if (.not.(memc(str1) .eq. 66 .or. memc(str1) .eq. 98)) + * goto 520 + radecs = 1 + ip = ip + 1 + if (.not.(ctod (memc(str1), ip, equinx) .le. 0)) goto + * 530 + equinx = 1950.0d0 +530 continue + call gargwd (memc(str2), 1023 ) + if (.not.(nscan() .le. nitems)) goto 540 + epoch = sleb2d (equinx) + goto 541 +540 continue + if (.not.(memc(str2) .eq. 74 .or. memc(str2) .eq. + * 106)) goto 550 + ip = 2 + goto 551 +550 continue + if (.not.(memc(str2) .eq. 66 .or. memc(str2) .eq. + * 98)) goto 560 + ip = 2 + goto 561 +560 continue + ip = 1 +561 continue +551 continue + if (.not.(ctod (memc(str2), ip, epoch) .le. 0)) + * goto 570 + epoch = sleb2d (equinx) + goto 571 +570 continue + if (.not.(epoch .le. 3000.0d0 .and. (memc(str2) .eq + * . 74 .or. memc(str2) .eq. 106))) goto 580 + epoch = slej2d (epoch) + goto 581 +580 continue + if (.not.(epoch .gt. 3000.0d0)) goto 590 + epoch = epoch - 2400000.5d0 + goto 591 +590 continue + epoch = sleb2d (epoch) +591 continue +581 continue +571 continue +541 continue + goto 521 +520 continue + if (.not.(memc(str1) .eq. 74 .or. memc(str1) .eq. 106)) + * goto 600 + radecs = 3 + ip = ip + 1 + if (.not.(ctod (memc(str1), ip, equinx) .le. 0)) goto + * 610 + equinx = 2000.0d0 +610 continue + call gargwd (memc(str2), 1023 ) + if (.not.(nscan() .le. nitems)) goto 620 + epoch = slej2d (equinx) + goto 621 +620 continue + if (.not.(memc(str2) .eq. 74 .or. memc(str2) .eq. + * 106 .or. memc(str2) .eq. 66 .or. memc(str2) .eq. 98 + * )) goto 630 + ip = 2 + goto 631 +630 continue + ip = 1 +631 continue + if (.not.(ctod (memc(str2), ip, epoch) .le. 0)) + * goto 640 + epoch = slej2d (equinx) + goto 641 +640 continue + if (.not.(epoch .le. 3000.0d0 .and. (memc(str2) .eq + * . 66 .or. memc(str2) .eq. 98))) goto 650 + epoch = sleb2d (epoch) + goto 651 +650 continue + if (.not.(epoch .gt. 3000.0d0)) goto 660 + epoch = epoch - 2400000.5d0 + goto 661 +660 continue + epoch = slej2d (epoch) +661 continue +651 continue +641 continue +621 continue + goto 601 +600 continue + if (.not.(ctod (memc(str1), ip, equinx) .le. 0)) goto 670 + ctype = 0 + radecs = 0 + equinx = 1.6d308 + epoch = 1.6d308 + goto 671 +670 continue + if (.not.(equinx .lt. 1984.0d0)) goto 680 + radecs = 1 + call gargwd (memc(str2), 1023 ) + if (.not.(nscan() .le. nitems)) goto 690 + epoch = sleb2d (equinx) + goto 691 +690 continue + if (.not.(memc(str2) .eq. 74 .or. memc(str2) .eq. + * 106 .or. memc(str2) .eq. 66 .or. memc(str2) .eq. 98 + * )) goto 700 + ip = 2 + goto 701 +700 continue + ip = 1 +701 continue + if (.not.(ctod (memc(str2), ip, epoch) .le. 0)) + * goto 710 + epoch = sleb2d (equinx) + goto 711 +710 continue + if (.not.(epoch .le. 3000.0d0 .and. (memc(str2) .eq + * . 74 .or. memc(str2) .eq. 106))) goto 720 + epoch = slej2d (epoch) + goto 721 +720 continue + if (.not.(epoch .gt. 3000.0d0)) goto 730 + epoch = epoch - 2400000.5d0 + goto 731 +730 continue + epoch = sleb2d (epoch) +731 continue +721 continue +711 continue +691 continue + goto 681 +680 continue + radecs = 3 + call gargwd (memc(str2), 1023 ) + if (.not.(nscan() .le. nitems)) goto 740 + epoch = slej2d (equinx) + goto 741 +740 continue + if (.not.(memc(str2) .eq. 74 .or. memc(str2) .eq. + * 106 .or. memc(str2) .eq. 66 .or. memc(str2) .eq. 98 + * )) goto 750 + ip = 2 + goto 751 +750 continue + ip = 1 +751 continue + if (.not.(ctod (memc(str2), ip, epoch) .le. 0)) + * goto 760 + epoch = slej2d (equinx) + goto 761 +760 continue + if (.not.(epoch .le. 3000.0d0 .and. (memc(str2) .eq + * . 66 .or. memc(str2) .eq. 98))) goto 770 + epoch = sleb2d (epoch) + goto 771 +770 continue + if (.not.(epoch .gt. 3000.0d0)) goto 780 + epoch = epoch - 2400000.5d0 + goto 781 +780 continue + epoch = slej2d (epoch) +781 continue +771 continue +761 continue +741 continue +681 continue +671 continue +601 continue +521 continue + goto 251 +250 continue + if (sw0003.lt.1.or.sw0003.gt.5) goto 510 + goto (260,260,350,350,440),sw0003 +251 continue + goto 231 +790 continue + if (.not.(memc(str1) .eq. 74 .or. memc(str1) .eq. 106 .or. + * memc(str1) .eq. 66 .or. memc(str1) .eq. 98)) goto 800 + ip = 2 + goto 801 +800 continue + ip = 1 +801 continue + if (.not.(ctod (memc(str1), ip, epoch) .le. 0)) goto 810 + epoch = 1.6d308 + goto 811 +810 continue + if (.not.(epoch .le. 3000.0d0)) goto 820 + if (.not.(memc(str1) .eq. 66 .or. memc(str1) .eq. 98)) + * goto 830 + epoch = sleb2d (epoch) + goto 831 +830 continue + if (.not.(memc(str1) .eq. 74 .or. memc(str1) .eq. 106)) + * goto 840 + epoch = slej2d (epoch) + goto 841 +840 continue + if (.not.(epoch .lt. 1984.0d0)) goto 850 + epoch = sleb2d (epoch) + goto 851 +850 continue + epoch = slej2d (epoch) +851 continue +841 continue +831 continue + goto 821 +820 continue + epoch = epoch - 2400000.5d0 +821 continue +811 continue + goto 231 +860 continue + if (.not.(memc(str1) .eq. 74 .or. memc(str1) .eq. 106 .or. + * memc(str1) .eq. 66 .or. memc(str1) .eq. 98)) goto 870 + ip = 2 + goto 871 +870 continue + ip = 1 +871 continue + if (.not.(ctod (memc(str1), ip, epoch) .le. 0)) goto 880 + epoch = sleb2d (1950.0d0) + goto 881 +880 continue + if (.not.(epoch .le. 3000.0d0)) goto 890 + if (.not.(memc(str1) .eq. 74 .or. memc(str1) .eq. 106)) + * goto 900 + epoch = slej2d (epoch) + goto 901 +900 continue + if (.not.(memc(str1) .eq. 66 .or. memc(str1) .eq. 98)) + * goto 910 + epoch = sleb2d (epoch) + goto 911 +910 continue + if (.not.(epoch .lt. 1984.0d0)) goto 920 + epoch = sleb2d (epoch) + goto 921 +920 continue + epoch = slej2d (epoch) +921 continue +911 continue +901 continue + goto 891 +890 continue + epoch = epoch - 2400000.5d0 +891 continue +881 continue + goto 231 +230 continue + if (sw0002.lt.1.or.sw0002.gt.4) goto 231 + goto (240,790,860,860),sw0002 +231 continue + if (.not.(ctype .eq. 0)) goto 930 + stat = -1 + goto 931 +930 continue + if (.not.(ctype .eq. 1 .and. (radecs .eq. 0 .or. ((equinx).eq.1 + * .6d308) .or. ((epoch).eq.1.6d308)))) goto 940 + stat = -1 + goto 941 +940 continue + if (.not.(ctype .eq. 2 .and. ((epoch).eq.1.6d308))) goto 950 + stat = -1 + goto 951 +950 continue + stat = 0 +951 continue +941 continue +931 continue + call sfree (sp) + skstrs = (stat) + goto 100 +100 return + end + integer function skimws (im, mw, ctype, lngax, latax, wtype, + *radecs, equinx, epoch) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer im + integer mw + integer ctype + integer lngax + integer latax + integer wtype + integer radecs + double precision equinx + double precision epoch + integer i + integer ndim + integer axtype + integer day + integer month + integer year + integer ier + integer oldfis + integer sp + integer atval + double precision hours + double precision imgetd + double precision sleb2d + double precision slej2d + integer mwstai + integer strdic + integer dtmdee + logical xerpop + logical xerflg + common /xercom/ xerflg + integer sw0001,sw0002,sw0003 + integer*2 st0001(7) + integer*2 st0002(6) + integer*2 st0003(39) + integer*2 st0004(6) + integer*2 st0005(6) + integer*2 st0006(7) + integer*2 st0007(114) + integer*2 st0008(8) + integer*2 st0009(6) + integer*2 st0010(9) + integer*2 st0011(30) + integer*2 st0012(8) + integer*2 st0013(8) + integer*2 st0014(9) + integer*2 st0015(8) + integer*2 st0016(8) + integer*2 st0017(9) + integer*2 st0018(8) + integer*2 st0019(8) + integer*2 st0020(9) + save + integer iyy + data st0001 / 97,120,116,121,112,101, 0/ + data st0002 / 73, 78, 68, 69, 70, 0/ + data (st0003(iyy),iyy= 1, 8) /124,114, 97,124,100,101, 99,124/ + data (st0003(iyy),iyy= 9,16) /103,108,111,110,124,103,108, 97/ + data (st0003(iyy),iyy=17,24) /116,124,101,108,111,110,124,101/ + data (st0003(iyy),iyy=25,32) /108, 97,116,124,115,108,111,110/ + data (st0003(iyy),iyy=33,39) /124,115,108, 97,116,124, 0/ + data st0004 /119,116,121,112,101, 0/ + data st0005 /119,116,121,112,101, 0/ + data st0006 /108,105,110,101, 97,114, 0/ + data (st0007(iyy),iyy= 1, 8) /124,108,105,110,124, 97,122,112/ + data (st0007(iyy),iyy= 9,16) /124,116, 97,110,124,115,105,110/ + data (st0007(iyy),iyy=17,24) /124,115,116,103,124, 97,114, 99/ + data (st0007(iyy),iyy=25,32) /124,122,112,110,124,122,101, 97/ + data (st0007(iyy),iyy=33,40) /124, 97,105,114,124, 99,121,112/ + data (st0007(iyy),iyy=41,48) /124, 99, 97,114,124,109,101,114/ + data (st0007(iyy),iyy=49,56) /124, 99,101, 97,124, 99,111,112/ + data (st0007(iyy),iyy=57,64) /124, 99,111,100,124, 99,111,101/ + data (st0007(iyy),iyy=65,72) /124, 99,111,111,124, 98,111,110/ + data (st0007(iyy),iyy=73,80) /124,112, 99,111,124,103,108,115/ + data (st0007(iyy),iyy=81,88) /124,112, 97,114,124, 97,105,116/ + data (st0007(iyy),iyy=89,96) /124,109,111,108,124, 99,115, 99/ + data (st0007(iyy),iyy=97,104) /124,113,115, 99,124,116,115, 99/ + data (st0007(iyy),iyy=105,112) /124,116,110,120,124,122,112,120/ + data (st0007(iyy),iyy=113,114) /124, 0/ + data st0008 / 69, 81, 85, 73, 78, 79, 88, 0/ + data st0009 / 69, 80, 79, 67, 72, 0/ + data (st0010(iyy),iyy= 1, 8) / 82, 65, 68, 69, 67, 83, 89, 83/ + data (st0010(iyy),iyy= 9, 9) / 0/ + data (st0011(iyy),iyy= 1, 8) /124,102,107, 52,124,102,107, 52/ + data (st0011(iyy),iyy= 9,16) / 45,110,111, 45,101,124,102,107/ + data (st0011(iyy),iyy=17,24) / 53,124,105, 99,114,115,124,103/ + data (st0011(iyy),iyy=25,30) / 97,112,112,116,124, 0/ + data st0012 / 77, 74, 68, 45, 87, 67, 83, 0/ + data st0013 / 77, 74, 68, 45, 79, 66, 83, 0/ + data (st0014(iyy),iyy= 1, 8) / 68, 65, 84, 69, 45, 79, 66, 83/ + data (st0014(iyy),iyy= 9, 9) / 0/ + data st0015 / 77, 74, 68, 45, 87, 67, 83, 0/ + data st0016 / 77, 74, 68, 45, 79, 66, 83, 0/ + data (st0017(iyy),iyy= 1, 8) / 68, 65, 84, 69, 45, 79, 66, 83/ + data (st0017(iyy),iyy= 9, 9) / 0/ + data st0018 / 77, 74, 68, 45, 87, 67, 83, 0/ + data st0019 / 77, 74, 68, 45, 79, 66, 83, 0/ + data (st0020(iyy),iyy= 1, 8) / 68, 65, 84, 69, 45, 79, 66, 83/ + data (st0020(iyy),iyy= 9, 9) / 0/ + call smark (sp) + call salloc (atval, 1023 , 2) + ctype = 0 + lngax = 0 + latax = 0 + wtype = 0 + radecs = 0 + equinx = 1.6d308 + epoch = 1.6d308 + ndim = mwstai (mw, 5 ) + do 110 i = 1, ndim + call xerpsh + call mwgwas (mw, i, st0001, memc(atval), 1023 ) + if (.not.xerpop()) goto 120 + call xstrcy(st0002, memc(atval), 1023 ) +120 continue + axtype = strdic (memc(atval), memc(atval), 1023 , st0003) + sw0001=(axtype) + goto 130 +140 continue + ctype = 1 + goto 131 +150 continue + ctype = 2 + goto 131 +160 continue + ctype = 3 + goto 131 +170 continue + ctype = 4 + goto 131 +180 continue + goto 131 +130 continue + if (sw0001.lt.1.or.sw0001.gt.8) goto 180 + goto (140,140,160,160,150,150,170,170),sw0001 +131 continue + sw0002=(axtype) + goto 190 +200 continue + lngax = i + goto 191 +210 continue + latax = i + goto 191 +220 continue + goto 191 +190 continue + if (sw0002.lt.1.or.sw0002.gt.8) goto 220 + goto (200,210,200,210,200,210,200,210),sw0002 +191 continue +110 continue +111 continue + if (.not.(ctype .eq. 0 .or. lngax .eq. 0 .or. latax .eq. 0)) + * goto 230 + call sfree (sp) + skimws = (-1) + goto 100 +230 continue + call xerpsh + call mwgwas (mw, lngax, st0004, memc(atval), 1023 ) + if (xerflg) goto 242 +242 if (.not.xerpop()) goto 240 + call xerpsh + call mwgwas(mw, latax, st0005, memc(atval), 1023 ) + if (.not.xerpop()) goto 250 + call xstrcy(st0006, memc(atval), 1023 ) +250 continue +240 continue + wtype = strdic (memc(atval), memc(atval), 1023 , st0007) + if (.not.(wtype .eq. 0)) goto 260 + call sfree (sp) + skimws = (-1) + goto 100 +260 continue + if (.not.(ctype .eq. 1)) goto 270 + call xerpsh + equinx = imgetd (im, st0008) + if (xerflg) goto 282 +282 if (.not.xerpop()) goto 280 + call xerpsh + equinx = imgetd (im, st0009) + if (xerflg) goto 292 +292 if (.not.xerpop()) goto 290 + equinx = 1.6d308 +290 continue +280 continue + call xerpsh + call imgstr (im, st0010, memc(atval), 1023 ) + if (xerflg) goto 302 +302 if (.not.xerpop()) goto 300 + radecs = 0 + goto 301 +300 continue + call strlwr (memc(atval)) + radecs = strdic (memc(atval), memc(atval), 1023 , st0011) +301 continue + if (.not.(radecs .eq. 0)) goto 310 + if (.not.(((equinx).eq.1.6d308))) goto 320 + radecs = 3 + goto 321 +320 continue + if (.not.(equinx .lt. 1984.0d0)) goto 330 + radecs = 1 + goto 331 +330 continue + radecs = 3 +331 continue +321 continue +310 continue + call xerpsh + epoch = imgetd (im, st0012) + if (xerflg) goto 342 +342 if (.not.xerpop()) goto 340 + call xerpsh + epoch = imgetd (im, st0013) + if (xerflg) goto 352 +352 if (.not.xerpop()) goto 350 + call xerpsh + call imgstr (im, st0014, memc(atval), 1023 ) + if (xerflg) goto 362 +362 if (.not.xerpop()) goto 360 + epoch = 1.6d308 + goto 361 +360 continue + if (.not.(dtmdee (memc(atval), year, month, day, hours + * , oldfis) .eq. 0)) goto 370 + call slcadj (year, month, day, epoch, ier) + if (.not.(ier .ne. 0)) goto 380 + epoch = 1.6d308 + goto 381 +380 continue + if (.not.(.not. ((hours).eq.1.6d308) .and. hours . + * ge. 0.0d0 .and. hours .le. 24.0d0)) goto 390 + epoch = epoch + hours / 24.0d0 +390 continue +381 continue + goto 371 +370 continue + epoch = 1.6d308 +371 continue +361 continue +350 continue +340 continue + sw0003=(radecs) + goto 400 +410 continue + if (.not.(((equinx).eq.1.6d308))) goto 420 + equinx = 1950.0d0 +420 continue + if (.not.(((epoch).eq.1.6d308))) goto 430 + epoch = sleb2d (1950.0d0) +430 continue + goto 401 +440 continue + if (.not.(((equinx).eq.1.6d308))) goto 450 + equinx = 2000.0d0 +450 continue + if (.not.(((epoch).eq.1.6d308))) goto 460 + epoch = slej2d (2000.0d0) +460 continue + goto 401 +470 continue + equinx = 2000.0d0 + goto 401 +400 continue + if (sw0003.lt.1.or.sw0003.gt.5) goto 401 + goto (410,410,440,440,470),sw0003 +401 continue + if (.not.(((epoch).eq.1.6d308))) goto 480 + call sfree (sp) + skimws = (-1) + goto 100 +480 continue +270 continue + if (.not.(ctype .eq. 2)) goto 490 + call xerpsh + epoch = imgetd (im, st0015) + if (xerflg) goto 502 +502 if (.not.xerpop()) goto 500 + call xerpsh + epoch = imgetd (im, st0016) + if (xerflg) goto 512 +512 if (.not.xerpop()) goto 510 + call xerpsh + call imgstr (im, st0017, memc(atval), 1023 ) + if (xerflg) goto 522 +522 if (.not.xerpop()) goto 520 + epoch = 1.6d308 + goto 521 +520 continue + if (.not.(dtmdee (memc(atval), year, month, day, hours + * , oldfis) .eq. 0)) goto 530 + call slcadj (year, month, day, epoch, ier) + if (.not.(ier .ne. 0)) goto 540 + epoch = 1.6d308 + goto 541 +540 continue + if (.not.(.not. ((hours).eq.1.6d308) .and. hours . + * ge. 0.0d0 .and. hours .le. 24.0d0)) goto 550 + epoch = epoch + hours / 24.0d0 +550 continue +541 continue + goto 531 +530 continue + epoch = 1.6d308 +531 continue +521 continue +510 continue +500 continue + if (.not.(((epoch).eq.1.6d308))) goto 560 + call sfree (sp) + skimws = (-1) + goto 100 +560 continue +490 continue + if (.not.(ctype .eq. 3 .or. ctype .eq. 4)) goto 570 + call xerpsh + epoch = imgetd (im, st0018) + if (xerflg) goto 582 +582 if (.not.xerpop()) goto 580 + call xerpsh + epoch = imgetd (im, st0019) + if (xerflg) goto 592 +592 if (.not.xerpop()) goto 590 + call xerpsh + call imgstr (im, st0020, memc(atval), 1023 ) + if (xerflg) goto 602 +602 if (.not.xerpop()) goto 600 + epoch = sleb2d (1950.0d0) + goto 601 +600 continue + if (.not.(dtmdee (memc(atval), year, month, day, hours + * , oldfis) .eq. 0)) goto 610 + call slcadj (year, month, day, epoch, ier) + if (.not.(ier .ne. 0)) goto 620 + epoch = sleb2d (1950.0d0) + goto 621 +620 continue + if (.not.(.not. ((hours).eq.1.6d308) .and. hours + * .ge. 0.0d0 .and. hours .le. 24.0d0)) goto 630 + epoch = epoch + hours / 24.0d0 +630 continue +621 continue + goto 611 +610 continue + epoch = sleb2d (1950.0d0) +611 continue +601 continue +590 continue +580 continue +570 continue + call sfree (sp) + skimws = (0) + goto 100 +100 return + end + subroutine skenws (coo, wcsstr, maxch) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer coo + integer maxch + integer*2 wcsstr(*) + double precision skstad + double precision slepj + double precision slepb + integer skstai + integer sw0001,sw0002 + integer*2 st0001(9) + integer*2 st0002(16) + integer*2 st0003(18) + integer*2 st0004(19) + integer*2 st0005(18) + integer*2 st0006(21) + integer*2 st0007(9) + integer*2 st0008(16) + integer*2 st0009(16) + integer*2 st0010(21) + save + integer iyy + data (st0001(iyy),iyy= 1, 8) / 97,112,112, 97,114,101,110,116/ + data (st0001(iyy),iyy= 9, 9) / 0/ + data (st0002(iyy),iyy= 1, 8) / 97,112,112, 97,114,101,110,116/ + data (st0002(iyy),iyy= 9,16) / 32, 74, 37, 48, 46, 56,102, 0/ + data (st0003(iyy),iyy= 1, 8) /102,107, 53, 32, 74, 37, 48, 46/ + data (st0003(iyy),iyy= 9,16) / 51,102, 32, 74, 37, 48, 46, 56/ + data (st0003(iyy),iyy=17,18) /102, 0/ + data (st0004(iyy),iyy= 1, 8) /105, 99,114,115, 32, 74, 37, 48/ + data (st0004(iyy),iyy= 9,16) / 46, 51,102, 32, 74, 37, 48, 46/ + data (st0004(iyy),iyy=17,19) / 56,102, 0/ + data (st0005(iyy),iyy= 1, 8) /102,107, 52, 32, 66, 37, 48, 46/ + data (st0005(iyy),iyy= 9,16) / 51,102, 32, 66, 37, 48, 46, 56/ + data (st0005(iyy),iyy=17,18) /102, 0/ + data (st0006(iyy),iyy= 1, 8) /102,107, 52,110,111,101, 32, 66/ + data (st0006(iyy),iyy= 9,16) / 37, 48, 46, 51,102, 32, 66, 37/ + data (st0006(iyy),iyy=17,21) / 48, 46, 56,102, 0/ + data (st0007(iyy),iyy= 1, 8) /101, 99,108,105,112,116,105, 99/ + data (st0007(iyy),iyy= 9, 9) / 0/ + data (st0008(iyy),iyy= 1, 8) /101, 99,108,105,112,116,105, 99/ + data (st0008(iyy),iyy= 9,16) / 32, 74, 37, 48, 46, 56,102, 0/ + data (st0009(iyy),iyy= 1, 8) /103, 97,108, 97, 99,116,105, 99/ + data (st0009(iyy),iyy= 9,16) / 32, 74, 37, 48, 46, 56,102, 0/ + data (st0010(iyy),iyy= 1, 8) /115,117,112,101,114,103, 97,108/ + data (st0010(iyy),iyy= 9,16) / 97, 99,116,105, 99, 32,106, 37/ + data (st0010(iyy),iyy=17,21) / 48, 46, 56,102, 0/ + sw0001=(skstai (coo, 7)) + goto 110 +120 continue + sw0002=(skstai(coo, 8)) + goto 130 +140 continue + if (.not.(((skstad(coo, 6)).eq.1.6d308))) goto 150 + call sprinf (wcsstr, maxch, st0001) + goto 151 +150 continue + call sprinf (wcsstr, maxch, st0002) + call pargd (slepj(skstad(coo, 6))) +151 continue + goto 131 +160 continue + call sprinf (wcsstr, maxch, st0003) + call pargd (skstad(coo, 5)) + call pargd (slepj(skstad(coo, 6))) + goto 131 +170 continue + call sprinf (wcsstr, maxch, st0004) + call pargd (skstad(coo, 5)) + call pargd (slepj(skstad(coo, 6))) + goto 131 +180 continue + call sprinf (wcsstr, maxch, st0005) + call pargd (skstad(coo, 5)) + call pargd (slepb(skstad(coo, 6))) + goto 131 +190 continue + call sprinf (wcsstr, maxch, st0006) + call pargd (skstad(coo, 5)) + call pargd (slepb(skstad(coo, 6))) + goto 131 +200 continue + wcsstr(1) = 0 + goto 131 +130 continue + if (sw0002.lt.1.or.sw0002.gt.5) goto 200 + goto (180,190,160,170,140),sw0002 +131 continue + goto 111 +210 continue + if (.not.(((skstad(coo, 6)).eq.1.6d308))) goto 220 + call sprinf (wcsstr, maxch, st0007) + goto 221 +220 continue + call sprinf (wcsstr, maxch, st0008) + call pargd (slepj(skstad(coo, 6))) +221 continue + goto 111 +230 continue + call sprinf (wcsstr, maxch, st0009) + call pargd (slepj(skstad(coo, 6))) + goto 111 +240 continue + call sprinf (wcsstr, maxch, st0010) + call pargd (slepj(skstad(coo, 6))) + goto 111 +110 continue + if (sw0001.lt.1.or.sw0001.gt.4) goto 111 + goto (120,210,230,240),sw0001 +111 continue +100 return + end + integer function skcopy (cooin) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer cooin + integer cooout + save + if (.not.(cooin .eq. 0)) goto 110 + cooout = 0 + goto 111 +110 continue + call xcallc(cooout, (30 + 255 + 1), 10 ) + memd((((cooout)-1)/2+1)) = memd((((cooin)-1)/2+1)) + memd((((cooout+2)-1)/2+1)) = memd((((cooin+2)-1)/2+1)) + memd((((cooout+4)-1)/2+1)) = memd((((cooin+4)-1)/2+1)) + memd((((cooout+6)-1)/2+1)) = memd((((cooin+6)-1)/2+1)) + memd((((cooout+8)-1)/2+1)) = memd((((cooin+8)-1)/2+1)) + memd((((cooout+10)-1)/2+1)) = memd((((cooin+10)-1)/2+1)) + memi(cooout+12) = memi(cooin+12) + memi(cooout+13) = memi(cooin+13) + memi(cooout+14) = memi(cooin+14) + memi(cooout+15) = memi(cooin+15) + memi(cooout+16) = memi(cooin+16) + memi(cooout+17) = memi(cooin+17) + memi(cooout+18) = memi(cooin+18) + memi(cooout+19) = memi(cooin+19) + memi(cooout+20) = memi(cooin+20) + memi(cooout+21) = memi(cooin+21) + memi(cooout+22) = memi(cooin+22) + memi(cooout+23) = memi(cooin+23) + call xstrcy(memc((((cooin+25)-1)*2+1)) , memc((((cooout+25)- + * 1)*2+1)) , 255 ) +111 continue + skcopy = (cooout) + goto 100 +100 return + end + subroutine skcloe (coo) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer coo + save + if (.not.(coo .ne. 0)) goto 110 + call xmfree(coo, 10 ) +110 continue +100 return + end +c sprinf sprintf +c dtmdee dtm_decode +c skenws sk_enwcs +c skstad sk_statd +c radecs radecsys +c equinx equinox +c skdecs sk_decwcs +c skimws sk_imwcs +c skstrs sk_strwcs +c skdecr sk_decwstr +c skstai sk_stati +c mwstai mw_stati +c skdecm sk_decim +c mwgaxp mw_gaxmap +c gargwd gargwrd +c sleb2d sl_eb2d +c mwopem mw_openim +c oldfis oldfits +c imunmp imunmap +c mwgwas mw_gwattrs +c skcopy sk_copy +c slej2d sl_ej2d +c srades sradecsys +c slcadj sl_cadj +c skcloe sk_close +c pargsr pargstr +c mwcloe mw_close diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skdecode.x b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skdecode.x new file mode 100644 index 00000000..5fa88f3b --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skdecode.x @@ -0,0 +1,999 @@ +include <imio.h> +include <imhdr.h> +include <mwset.h> +include "skywcs.h" +include "skywcsdef.h" + +# SK_DECWCS -- Decode the wcs string which may be either an image name +# plus wcs, e.g. "dev$pix logical" or a string describing the celestial +# coordinate system, e.g. "J2000" or "galactic" into a celestial coordinate +# structure. If the input wcs is an image wcs then a non-NULL pointer to +# the image wcs structure is also returned. ERR is returned if a valid +# celestial coordinate structure cannot be created. + +int procedure sk_decwcs (instr, mw, coo, imcoo) + +char instr[ARB] #I the input wcs string +pointer mw #O the pointer to the image wcs structure +pointer coo #O the pointer to the coordinate structure +pointer imcoo #I pointer to an existing coordinate structure + +int stat +pointer sp, str1, str2, laxno, paxval, im +int sk_strwcs(), sk_decim() +pointer immap() +errchk immap() + +begin + call calloc (coo, LEN_SKYCOOSTRUCT, TY_STRUCT) + call strcpy (instr, SKY_COOSYSTEM(coo), SZ_FNAME) + + # Allocate some working space. + call smark (sp) + call salloc (str1, SZ_LINE, TY_CHAR) + call salloc (str2, SZ_LINE, TY_CHAR) + call salloc (laxno, IM_MAXDIM, TY_INT) + call salloc (paxval, IM_MAXDIM, TY_INT) + + # Decode the wcs. + call sscan (instr) + call gargwrd (Memc[str1], SZ_LINE) + call gargwrd (Memc[str2], SZ_LINE) + + # First try to open an image wcs. + iferr { + im = immap (Memc[str1], READ_ONLY, 0) + + # Decode the user wcs. + } then { + + # Initialize. + mw = NULL + if (imcoo == NULL) { + SKY_NLNGAX(coo) = 2048 + SKY_NLATAX(coo) = 2048 + SKY_PLNGAX(coo) = 1 + SKY_PLATAX(coo) = 2 + SKY_XLAX(coo) = 1 + SKY_YLAX(coo) = 2 + SKY_VXOFF(coo) = 0.0d0 + SKY_VYOFF(coo) = 0.0d0 + SKY_VXSTEP(coo) = 1.0d0 + SKY_VYSTEP(coo) = 1.0d0 + SKY_WTYPE(coo) = 0 + } else { + SKY_NLNGAX(coo) = SKY_NLNGAX(imcoo) + SKY_NLATAX(coo) = SKY_NLATAX(imcoo) + SKY_PLNGAX(coo) = SKY_PLNGAX(imcoo) + SKY_PLATAX(coo) = SKY_PLATAX(imcoo) + SKY_XLAX(coo) = SKY_XLAX(imcoo) + SKY_YLAX(coo) = SKY_YLAX(imcoo) + SKY_VXOFF(coo) = SKY_VXOFF(imcoo) + SKY_VYOFF(coo) = SKY_VYOFF(imcoo) + SKY_VXSTEP(coo) = SKY_VXSTEP(imcoo) + SKY_VYSTEP(coo) = SKY_VYSTEP(imcoo) + SKY_WTYPE(coo) = SKY_WTYPE(imcoo) + } + SKY_PIXTYPE(coo) = PIXTYPE_WORLD + + # Decode the actual wcs. + stat = sk_strwcs (instr, SKY_CTYPE(coo), SKY_RADECSYS(coo), + SKY_EQUINOX(coo), SKY_EPOCH(coo)) + switch (SKY_CTYPE(coo)) { + case CTYPE_EQUATORIAL: + SKY_NLNGUNITS(coo) = SKY_HOURS + SKY_NLATUNITS(coo) = SKY_DEGREES + default: + SKY_NLNGUNITS(coo) = SKY_DEGREES + SKY_NLATUNITS(coo) = SKY_DEGREES + } + + # Decode the image wcs. + } else { + stat = sk_decim (im, Memc[str2], mw, coo) + call imunmap (im) + } + + call sfree (sp) + + SKY_STATUS(coo) = stat + return (stat) +end + + +# SK_DECWSTR -- Decode the wcs string coordinate system, e.g. "J2000" or +# "galactic" into a celestial coordinate structure. ERR is returned if a +# valid celestial coordinate structure cannot be created. + +int procedure sk_decwstr (instr, coo, imcoo) + +char instr[ARB] #I the input wcs string +pointer coo #O the pointer to the coordinate structure +pointer imcoo #I pointer to an existing coordinate structure + +int stat +int sk_strwcs() + +begin + call calloc (coo, LEN_SKYCOOSTRUCT, TY_STRUCT) + call strcpy (instr, SKY_COOSYSTEM(coo), SZ_FNAME) + + # Initialize. + if (imcoo == NULL) { + SKY_NLNGAX(coo) = 2048 + SKY_NLATAX(coo) = 2048 + SKY_PLNGAX(coo) = 1 + SKY_PLATAX(coo) = 2 + SKY_XLAX(coo) = 1 + SKY_YLAX(coo) = 2 + SKY_VXOFF(coo) = 0.0d0 + SKY_VYOFF(coo) = 0.0d0 + SKY_VXSTEP(coo) = 1.0d0 + SKY_VYSTEP(coo) = 1.0d0 + SKY_WTYPE(coo) = 0 + } else { + SKY_NLNGAX(coo) = SKY_NLNGAX(imcoo) + SKY_NLATAX(coo) = SKY_NLATAX(imcoo) + SKY_PLNGAX(coo) = SKY_PLNGAX(imcoo) + SKY_PLATAX(coo) = SKY_PLATAX(imcoo) + SKY_XLAX(coo) = SKY_XLAX(imcoo) + SKY_YLAX(coo) = SKY_YLAX(imcoo) + SKY_VXOFF(coo) = SKY_VXOFF(imcoo) + SKY_VYOFF(coo) = SKY_VYOFF(imcoo) + SKY_VXSTEP(coo) = SKY_VXSTEP(imcoo) + SKY_VYSTEP(coo) = SKY_VYSTEP(imcoo) + SKY_WTYPE(coo) = SKY_WTYPE(imcoo) + } + SKY_PIXTYPE(coo) = PIXTYPE_WORLD + + # Decode the actual wcs. + stat = sk_strwcs (instr, SKY_CTYPE(coo), SKY_RADECSYS(coo), + SKY_EQUINOX(coo), SKY_EPOCH(coo)) + switch (SKY_CTYPE(coo)) { + case CTYPE_EQUATORIAL: + SKY_NLNGUNITS(coo) = SKY_HOURS + SKY_NLATUNITS(coo) = SKY_DEGREES + default: + SKY_NLNGUNITS(coo) = SKY_DEGREES + SKY_NLATUNITS(coo) = SKY_DEGREES + } + + SKY_STATUS(coo) = stat + + return (stat) +end + + +# SK_DECIM -- Given an image descriptor and an image wcs string create a +# celstial coordinate structure. A non-NULL pointer to the image wcs structure +# is also returned. ERR is returned if a valid celestial coordinate descriptor +# cannot be created. + + +int procedure sk_decim (im, wcs, mw, coo) + +pointer im #I the pointer to the input image +char wcs[ARB] #I the wcs string [logical|tv|physical|world] +pointer mw #O the pointer to the image wcs structure +pointer coo #O the pointer to the coordinate structure + +int stat +pointer sp, str1, laxno, paxval +int sk_imwcs(), strdic(), mw_stati() +pointer mw_openim() +errchk mw_openim() + +begin + call malloc (coo, LEN_SKYCOOSTRUCT, TY_STRUCT) + call sprintf (SKY_COOSYSTEM(coo), SZ_FNAME, "%s %s") + call pargstr (IM_HDRFILE(im)) + call pargstr (wcs) + + call smark (sp) + call salloc (str1, SZ_LINE, TY_CHAR) + call salloc (laxno, IM_MAXDIM, TY_INT) + call salloc (paxval, IM_MAXDIM, TY_INT) + + # Try to open the image wcs. + iferr { + mw = mw_openim (im) + + # Set up a dummy wcs. + } then { + + #Initialize. + SKY_CTYPE(coo) = 0 + SKY_RADECSYS(coo) = 0 + SKY_EQUINOX(coo) = INDEFD + SKY_EPOCH(coo) = INDEFD + mw = NULL + SKY_PLNGAX(coo) = 1 + SKY_PLATAX(coo) = 2 + SKY_XLAX(coo) = 1 + SKY_YLAX(coo) = 2 + SKY_NLNGAX(coo) = 2048 + SKY_NLATAX(coo) = 2048 + SKY_VXOFF(coo) = 0.0d0 + SKY_VYOFF(coo) = 0.0d0 + SKY_VXSTEP(coo) = 1.0d0 + SKY_VYSTEP(coo) = 1.0d0 + SKY_WTYPE(coo) = 0 + SKY_PIXTYPE(coo) = PIXTYPE_LOGICAL + SKY_NLNGUNITS(coo) = SKY_DEGREES + SKY_NLATUNITS(coo) = SKY_DEGREES + stat = ERR + + # Decode the wcs. + } else { + SKY_PIXTYPE(coo) = strdic (wcs, Memc[str1], SZ_LINE, PIXTYPE_LIST) + if (SKY_PIXTYPE(coo) <= 0) + SKY_PIXTYPE(coo) = PIXTYPE_LOGICAL + if (sk_imwcs (im, mw, SKY_CTYPE(coo), SKY_PLNGAX(coo), + SKY_PLATAX(coo), SKY_WTYPE(coo), SKY_RADECSYS(coo), + SKY_EQUINOX(coo), SKY_EPOCH(coo)) == OK) { + switch (SKY_CTYPE(coo)) { + case CTYPE_EQUATORIAL: + SKY_NLNGUNITS(coo) = SKY_HOURS + SKY_NLATUNITS(coo) = SKY_DEGREES + default: + SKY_NLNGUNITS(coo) = SKY_DEGREES + SKY_NLATUNITS(coo) = SKY_DEGREES + } + call mw_gaxmap (mw, Memi[laxno], Memi[paxval], mw_stati(mw, + MW_NPHYSDIM)) + if (Memi[laxno+SKY_PLNGAX(coo)-1] < + Memi[laxno+SKY_PLATAX(coo)-1]) { + SKY_XLAX(coo) = Memi[laxno+SKY_PLNGAX(coo)-1] + SKY_YLAX(coo) = Memi[laxno+SKY_PLATAX(coo)-1] + } else { + SKY_XLAX(coo) = Memi[laxno+SKY_PLATAX(coo)-1] + SKY_YLAX(coo) = Memi[laxno+SKY_PLNGAX(coo)-1] + } + if (SKY_XLAX(coo) <= 0 || SKY_YLAX(coo) <= 0) { + SKY_VXOFF(coo) = 0.0d0 + SKY_VYOFF(coo) = 0.0d0 + SKY_VXSTEP(coo) = 1.0d0 + SKY_VYSTEP(coo) = 1.0d0 + SKY_NLNGAX(coo) = 2048 + SKY_NLATAX(coo) = 2048 + stat = ERR + } else { + SKY_VXOFF(coo) = IM_VOFF(im,IM_VMAP(im,SKY_XLAX(coo))) + SKY_VYOFF(coo) = IM_VOFF(im,IM_VMAP(im,SKY_YLAX(coo))) + SKY_VXSTEP(coo) = IM_VSTEP(im,SKY_XLAX(coo)) + SKY_VYSTEP(coo) = IM_VSTEP(im,SKY_YLAX(coo)) + SKY_NLNGAX(coo) = IM_LEN(im,SKY_XLAX(coo)) + SKY_NLATAX(coo) = IM_LEN(im,SKY_YLAX(coo)) + stat = OK + } + } else { + call mw_close (mw) + mw = NULL + SKY_XLAX(coo) = 1 + SKY_YLAX(coo) = 2 + SKY_NLNGAX(coo) = 2048 + SKY_NLATAX(coo) = 2048 + SKY_VXOFF(coo) = 0.0d0 + SKY_VYOFF(coo) = 0.0d0 + SKY_VXSTEP(coo) = 1.0d0 + SKY_VYSTEP(coo) = 1.0d0 + SKY_NLNGUNITS(coo) = SKY_DEGREES + SKY_NLATUNITS(coo) = SKY_DEGREES + stat = ERR + } + } + + call sfree (sp) + + SKY_STATUS(coo) = stat + return (stat) +end + + +# SK_STRWCS -- Decode the sky coordinate system from an input string. +# The string syntax is [ctype] equinox [epoch]. The various options +# have been placed case statements. Although there is considerable +# duplication of code in the case statements, there are minor differences +# and I found it clearer to write it out rather than trying to be +# concise. I might want to clean this up a bit later. + +int procedure sk_strwcs (instr, ctype, radecsys, equinox, epoch) + +char instr[ARB] #I the input wcs string +int ctype #O the output coordinate type +int radecsys #O the output equatorial reference system +double equinox #O the output equinox +double epoch #O the output epoch of the observation + +int ip, nitems, sctype, sradecsys, stat +pointer sp, str1, str2 +int strdic(), nscan(), ctod() +double sl_ej2d(), sl_epb(), sl_eb2d(), sl_epj() + +begin + # Initialize. + ctype = 0 + radecsys = 0 + equinox = INDEFD + epoch = INDEFD + + # Allocate working space. + call smark (sp) + call salloc (str1, SZ_LINE, TY_CHAR) + call salloc (str2, SZ_LINE, TY_CHAR) + + # Determine the coordinate string. + call sscan (instr) + call gargwrd (Memc[str1], SZ_LINE) + + # Return with an error if the string is blank. + if (Memc[str1] == EOS || nscan() < 1) { + call sfree (sp) + return (ERR) + } else + nitems = 1 + + # If the coordinate type is undefined temporarily default it to + # equatorial. + sctype = strdic (Memc[str1], Memc[str2], SZ_LINE, FTYPE_LIST) + if (sctype <= 0) { + ctype = CTYPE_EQUATORIAL + } else { + switch (sctype) { + case FTYPE_FK4: + ctype = CTYPE_EQUATORIAL + radecsys = EQTYPE_FK4 + case FTYPE_FK4NOE: + ctype = CTYPE_EQUATORIAL + radecsys = EQTYPE_FK4NOE + case FTYPE_FK5: + ctype = CTYPE_EQUATORIAL + radecsys = EQTYPE_FK5 + case FTYPE_ICRS: + ctype = CTYPE_EQUATORIAL + radecsys = EQTYPE_ICRS + case FTYPE_GAPPT: + ctype = CTYPE_EQUATORIAL + radecsys = EQTYPE_GAPPT + case FTYPE_ECLIPTIC: + ctype = CTYPE_ECLIPTIC + case FTYPE_GALACTIC: + ctype = CTYPE_GALACTIC + case FTYPE_SUPERGALACTIC: + ctype = CTYPE_SUPERGALACTIC + } + call gargwrd (Memc[str1], SZ_LINE) + if (nscan() > nitems) + nitems = nitems + 1 + } + sctype = ctype + sradecsys = radecsys + + # Decode the coordinate system. + switch (sctype) { + + # Decode the equatorial system, equinox, and epoch. + case CTYPE_EQUATORIAL: + + switch (sradecsys) { + case EQTYPE_FK4, EQTYPE_FK4NOE: + if (Memc[str1] == 'J' || Memc[str1] == 'j' || + Memc[str1] == 'B' || Memc[str1] == 'b') + ip = 2 + else + ip = 1 + if (ctod (Memc[str1], ip, equinox) <= 0) + equinox = 1950.0d0 + if (Memc[str1] == 'J' || Memc[str1] == 'j') + equinox = sl_epb (sl_ej2d (equinox)) + + call gargwrd (Memc[str2], SZ_LINE) + if (nscan() <= nitems) + epoch = sl_eb2d (equinox) + else { + if (Memc[str2] == 'J' || Memc[str2] == 'j' || + Memc[str2] == 'B' || Memc[str2] == 'b') + ip = 2 + else + ip = 1 + if (ctod (Memc[str2], ip, epoch) <= 0) + epoch = sl_eb2d (equinox) + else if (epoch <= 3000.0d0 && (Memc[str2] == 'J' || + Memc[str2] == 'j')) + epoch = sl_ej2d (epoch) + else if (epoch > 3000.0d0) + epoch = epoch - 2400000.5d0 + else + epoch = sl_eb2d (epoch) + } + + case EQTYPE_FK5, EQTYPE_ICRS: + if (Memc[str1] == 'J' || Memc[str1] == 'j' || + Memc[str1] == 'B' || Memc[str1] == 'b') + ip = 2 + else + ip = 1 + if (ctod (Memc[str1], ip, equinox) <= 0) + equinox = 2000.0d0 + if (Memc[str1] == 'B' || Memc[str1] == 'b') + equinox = sl_epj(sl_eb2d (equinox)) + + call gargwrd (Memc[str2], SZ_LINE) + if (nscan() <= nitems) + epoch = sl_ej2d (equinox) + else { + if (Memc[str2] == 'J' || Memc[str2] == 'j' || + Memc[str2] == 'B' || Memc[str2] == 'b') + ip = 2 + else + ip = 1 + if (ctod (Memc[str2], ip, epoch) <= 0) + epoch = sl_ej2d (equinox) + else if (epoch <= 3000.0d0 && (Memc[str2] == 'B' || + Memc[str2] == 'b')) + epoch = sl_eb2d (epoch) + else if (epoch > 3000.0d0) + epoch = epoch - 2400000.5d0 + else + epoch = sl_ej2d (epoch) + } + + case EQTYPE_GAPPT: + equinox = 2000.0d0 + if (Memc[str1] == 'J' || Memc[str1] == 'j' || + Memc[str1] == 'B' || Memc[str1] == 'b') + ip = 2 + else + ip = 1 + if (ctod (Memc[str1], ip, epoch) <= 0) { + epoch = INDEFD + } else if (epoch <= 3000.0d0) { + if (Memc[str1] == 'B' || Memc[str1] == 'b') + epoch = sl_eb2d (epoch) + else if (Memc[str1] == 'J' || Memc[str1] == 'j') + epoch = sl_ej2d (epoch) + else if (epoch < 1984.0d0) + epoch = sl_eb2d (epoch) + else + epoch = sl_ej2d (epoch) + } else { + epoch = epoch - 2400000.5d0 + } + + default: + ip = 1 + if (Memc[str1] == 'B' || Memc[str1] == 'b') { + radecsys = EQTYPE_FK4 + ip = ip + 1 + if (ctod (Memc[str1], ip, equinox) <= 0) + equinox = 1950.0d0 + + call gargwrd (Memc[str2], SZ_LINE) + if (nscan() <= nitems) + epoch = sl_eb2d (equinox) + else { + if (Memc[str2] == 'J' || Memc[str2] == 'j') + ip = 2 + else if (Memc[str2] == 'B' || Memc[str2] == 'b') + ip = 2 + else + ip = 1 + if (ctod (Memc[str2], ip, epoch) <= 0) + epoch = sl_eb2d (equinox) + else if (epoch <= 3000.0d0 && (Memc[str2] == 'J' || + Memc[str2] == 'j')) + epoch = sl_ej2d (epoch) + else if (epoch > 3000.0d0) + epoch = epoch - 2400000.5d0 + else + epoch = sl_eb2d (epoch) + } + + } else if (Memc[str1] == 'J' || Memc[str1] == 'j') { + radecsys = EQTYPE_FK5 + ip = ip + 1 + if (ctod (Memc[str1], ip, equinox) <= 0) + equinox = 2000.0d0 + + call gargwrd (Memc[str2], SZ_LINE) + if (nscan() <= nitems) + epoch = sl_ej2d (equinox) + else { + if (Memc[str2] == 'J' || Memc[str2] == 'j' || + Memc[str2] == 'B' || Memc[str2] == 'b') + ip = 2 + else + ip = 1 + if (ctod (Memc[str2], ip, epoch) <= 0) + epoch = sl_ej2d (equinox) + else if (epoch <= 3000.0d0 && (Memc[str2] == 'B' || + Memc[str2] == 'b')) + epoch = sl_eb2d (epoch) + else if (epoch > 3000.0d0) + epoch = epoch - 2400000.5d0 + else + epoch = sl_ej2d (epoch) + } + + } else if (ctod (Memc[str1], ip, equinox) <= 0) { + ctype = 0 + radecsys = 0 + equinox = INDEFD + epoch = INDEFD + + } else if (equinox < 1984.0d0) { + radecsys = EQTYPE_FK4 + call gargwrd (Memc[str2], SZ_LINE) + if (nscan() <= nitems) + epoch = sl_eb2d (equinox) + else { + if (Memc[str2] == 'J' || Memc[str2] == 'j' || + Memc[str2] == 'B' || Memc[str2] == 'b') + ip = 2 + else + ip = 1 + if (ctod (Memc[str2], ip, epoch) <= 0) + epoch = sl_eb2d (equinox) + else if (epoch <= 3000.0d0 && (Memc[str2] == 'J' || + Memc[str2] == 'j')) + epoch = sl_ej2d (epoch) + else if (epoch > 3000.0d0) + epoch = epoch - 2400000.5d0 + else + epoch = sl_eb2d (epoch) + } + + } else { + radecsys = EQTYPE_FK5 + call gargwrd (Memc[str2], SZ_LINE) + if (nscan() <= nitems) + epoch = sl_ej2d (equinox) + else { + if (Memc[str2] == 'J' || Memc[str2] == 'j' || + Memc[str2] == 'B' || Memc[str2] == 'b') + ip = 2 + else + ip = 1 + if (ctod (Memc[str2], ip, epoch) <= 0) + epoch = sl_ej2d (equinox) + else if (epoch <= 3000.0d0 && (Memc[str2] == 'B' || + Memc[str2] == 'b')) + epoch = sl_eb2d (epoch) + else if (epoch > 3000.0d0) + epoch = epoch - 2400000.5d0 + else + epoch = sl_ej2d (epoch) + } + } + } + + # Decode the ecliptic coordinate system. + case CTYPE_ECLIPTIC: + if (Memc[str1] == 'J' || Memc[str1] == 'j' || + Memc[str1] == 'B' || Memc[str1] == 'b') + ip = 2 + else + ip = 1 + if (ctod (Memc[str1], ip, epoch) <= 0) { + epoch = INDEFD + } else if (epoch <= 3000.0d0) { + if (Memc[str1] == 'B' || Memc[str1] == 'b') + epoch = sl_eb2d (epoch) + else if (Memc[str1] == 'J' || Memc[str1] == 'j') + epoch = sl_ej2d (epoch) + else if (epoch < 1984.0d0) + epoch = sl_eb2d (epoch) + else + epoch = sl_ej2d (epoch) + } else { + epoch = epoch - 2400000.5d0 + } + + # Decode the galactic and supergalactic coordinate system. + case CTYPE_GALACTIC, CTYPE_SUPERGALACTIC: + if (Memc[str1] == 'J' || Memc[str1] == 'j' || + Memc[str1] == 'B' || Memc[str1] == 'b') + ip = 2 + else + ip = 1 + if (ctod (Memc[str1], ip, epoch) <= 0) { + epoch = sl_eb2d (1950.0d0) + } else if (epoch <= 3000.0d0) { + if (Memc[str1] == 'J' || Memc[str1] == 'j') + epoch = sl_ej2d (epoch) + else if (Memc[str1] == 'B' || Memc[str1] == 'b') + epoch = sl_eb2d (epoch) + else if (epoch < 1984.0d0) + epoch = sl_eb2d (epoch) + else + epoch = sl_ej2d (epoch) + } else { + epoch = epoch - 2400000.5d0 + } + } + + # Return the appropriate error status. + if (ctype == 0) + stat = ERR + else if (ctype == CTYPE_EQUATORIAL && (radecsys == 0 || + IS_INDEFD(equinox) || IS_INDEFD(epoch))) + stat = ERR + else if (ctype == CTYPE_ECLIPTIC && IS_INDEFD(epoch)) + stat = ERR + else + stat = OK + + call sfree (sp) + + return (stat) +end + + +# SK_IMWCS -- Decode the sky coordinate system of the image. Return +# an error if the sky coordinate system is not one of the supported types +# or required information is missing from the image header. + +int procedure sk_imwcs (im, mw, ctype, lngax, latax, wtype, radecsys, + equinox, epoch) + +pointer im #I the image pointer +pointer mw #I pointer to the world coordinate system +int ctype #O the output coordinate type +int lngax #O the output ra/glon/elon axis +int latax #O the output dec/glat/elat axis +int wtype #O the output projection type +int radecsys #O the output equatorial reference system +double equinox #O the output equinox +double epoch #O the output epoch of the observation + +int i, ndim, axtype, day, month, year, ier, oldfits +pointer sp, atval +double hours +double imgetd(), sl_eb2d(), sl_ej2d() +int mw_stati(), strdic(), dtm_decode() +errchk mw_gwattrs(), imgstr(), imgetd() + +begin + call smark (sp) + call salloc (atval, SZ_LINE, TY_CHAR) + + # Initialize + ctype = 0 + lngax = 0 + latax = 0 + wtype = 0 + radecsys = 0 + equinox = INDEFD + epoch = INDEFD + + # Determine the sky coordinate system of the image. + ndim = mw_stati (mw, MW_NPHYSDIM) + do i = 1, ndim { + iferr (call mw_gwattrs (mw, i, "axtype", Memc[atval], SZ_LINE)) + call strcpy ("INDEF", Memc[atval], SZ_LINE) + axtype = strdic (Memc[atval], Memc[atval], SZ_LINE, AXTYPE_LIST) + switch (axtype) { + case AXTYPE_RA, AXTYPE_DEC: + ctype = CTYPE_EQUATORIAL + case AXTYPE_ELON, AXTYPE_ELAT: + ctype = CTYPE_ECLIPTIC + case AXTYPE_GLON, AXTYPE_GLAT: + ctype = CTYPE_GALACTIC + case AXTYPE_SLON, AXTYPE_SLAT: + ctype = CTYPE_SUPERGALACTIC + default: + ; + } + switch (axtype) { + case AXTYPE_RA, AXTYPE_ELON, AXTYPE_GLON, AXTYPE_SLON: + lngax = i + case AXTYPE_DEC, AXTYPE_ELAT, AXTYPE_GLAT, AXTYPE_SLAT: + latax = i + default: + ; + } + } + + # Return if the sky coordinate system cannot be decoded. + if (ctype == 0 || lngax == 0 || latax == 0) { + call sfree (sp) + return (ERR) + } + + # Decode the sky projection. + iferr { + call mw_gwattrs (mw, lngax, "wtype", Memc[atval], SZ_LINE) + } then { + iferr (call mw_gwattrs(mw, latax, "wtype", Memc[atval], SZ_LINE)) + call strcpy ("linear", Memc[atval], SZ_LINE) + } + wtype = strdic (Memc[atval], Memc[atval], SZ_LINE, WTYPE_LIST) + + # Return if the sky projection system is not supported. + if (wtype == 0) { + call sfree (sp) + return (ERR) + } + + # Determine the RA/DEC system and equinox. + if (ctype == CTYPE_EQUATORIAL) { + + # Get the equinox of the coordinate system. The EQUINOX keyword + # takes precedence over EPOCH. + iferr { + equinox = imgetd (im, "EQUINOX") + } then { + iferr { + equinox = imgetd (im, "EPOCH") + } then { + equinox = INDEFD + } + } + + # Determine which equatorial system will be used. The default + # is FK4 if equinox < 1984.0, FK5 if equinox is >= 1984. + iferr { + call imgstr (im, "RADECSYS", Memc[atval], SZ_LINE) + } then { + radecsys = 0 + } else { + call strlwr (Memc[atval]) + radecsys = strdic (Memc[atval], Memc[atval], SZ_LINE, + EQTYPE_LIST) + } + if (radecsys == 0) { + if (IS_INDEFD(equinox)) + radecsys = EQTYPE_FK5 + else if (equinox < 1984.0d0) + radecsys = EQTYPE_FK4 + else + radecsys = EQTYPE_FK5 + } + + # Get the MJD of the observation. If there is no MJD in the + # header use the DATE_OBS keyword value and transform it to + # an MJD. + iferr { + epoch = imgetd (im, "MJD-WCS") + } then { + iferr { + epoch = imgetd (im, "MJD-OBS") + } then { + iferr { + call imgstr (im, "DATE-OBS", Memc[atval], SZ_LINE) + } then { + epoch = INDEFD + } else if (dtm_decode (Memc[atval], year, month, day, + hours, oldfits) == OK) { + call sl_cadj (year, month, day, epoch, ier) + if (ier != 0) + epoch = INDEFD + else if (! IS_INDEFD(hours) && hours >= 0.0d0 && + hours <= 24.0d0) + epoch = epoch + hours / 24.0d0 + } else + epoch = INDEFD + } + } + + # Set the default equinox and epoch appropriate for each + # equatorial system if these are undefined. + switch (radecsys) { + case EQTYPE_FK4, EQTYPE_FK4NOE: + if (IS_INDEFD(equinox)) + equinox = 1950.0d0 + if (IS_INDEFD(epoch)) + epoch = sl_eb2d (1950.0d0) + case EQTYPE_FK5, EQTYPE_ICRS: + if (IS_INDEFD(equinox)) + equinox = 2000.0d0 + if (IS_INDEFD(epoch)) + epoch = sl_ej2d (2000.0d0) + case EQTYPE_GAPPT: + equinox = 2000.0d0 + ; + } + + # Return if the epoch is undefined. This can only occur if + # the equatorial coordinate system is GAPPT and there is NO + # epoch of observation in the image header. + if (IS_INDEFD(epoch)) { + call sfree (sp) + return (ERR) + } + } + + # Get the MJD of the observation. If there is no MJD in the + # header use the DATE_OBS keyword value and transform it to + # an MJD. + if (ctype == CTYPE_ECLIPTIC) { + + iferr { + epoch = imgetd (im, "MJD-WCS") + } then { + iferr { + epoch = imgetd (im, "MJD-OBS") + } then { + iferr { + call imgstr (im, "DATE-OBS", Memc[atval], SZ_LINE) + } then { + epoch = INDEFD + } else if (dtm_decode (Memc[atval], year, month, day, + hours, oldfits) == OK) { + call sl_cadj (year, month, day, epoch, ier) + if (ier != 0) + epoch = INDEFD + else if (! IS_INDEFD(hours) && hours >= 0.0d0 && + hours <= 24.0d0) + epoch = epoch + hours / 24.0d0 + } else + epoch = INDEFD + } + } + + # Return if the epoch is undefined. + if (IS_INDEFD(epoch)) { + call sfree (sp) + return (ERR) + } + } + + if (ctype == CTYPE_GALACTIC || ctype == CTYPE_SUPERGALACTIC) { + + # Get the MJD of the observation. If there is no MJD in the + # header use the DATE_OBS keyword value and transform it to + # an MJD. + iferr { + epoch = imgetd (im, "MJD-WCS") + } then { + iferr { + epoch = imgetd (im, "MJD-OBS") + } then { + iferr { + call imgstr (im, "DATE-OBS", Memc[atval], SZ_LINE) + } then { + epoch = sl_eb2d (1950.0d0) + } else if (dtm_decode (Memc[atval], year, month, day, + hours, oldfits) == OK) { + call sl_cadj (year, month, day, epoch, ier) + if (ier != 0) + epoch = sl_eb2d (1950.0d0) + else { + if (! IS_INDEFD(hours) && hours >= 0.0d0 && + hours <= 24.0d0) + epoch = epoch + hours / 24.0d0 + #if (epoch < 1984.0d0) + #epoch = sl_eb2d (epoch) + #else + #epoch = sl_ej2d (epoch) + } + } else + epoch = sl_eb2d (1950.0d0) + } + } + } + + call sfree (sp) + + return (OK) +end + + +# SK_ENWCS -- Encode the celestial wcs system. + +procedure sk_enwcs (coo, wcsstr, maxch) + +pointer coo #I the celestial coordinate system descriptor +char wcsstr[ARB] #O the output wcs string +int maxch #I the size of the output string + +double sk_statd(), sl_epj(), sl_epb() +int sk_stati() + +begin + switch (sk_stati (coo, S_CTYPE)) { + + case CTYPE_EQUATORIAL: + + switch (sk_stati(coo, S_RADECSYS)) { + + case EQTYPE_GAPPT: + if (IS_INDEFD(sk_statd(coo, S_EPOCH))) { + call sprintf (wcsstr, maxch, "apparent") + } else { + call sprintf (wcsstr, maxch, "apparent J%0.8f") + call pargd (sl_epj(sk_statd(coo, S_EPOCH))) + } + + case EQTYPE_FK5: + call sprintf (wcsstr, maxch, "fk5 J%0.3f J%0.8f") + call pargd (sk_statd(coo, S_EQUINOX)) + call pargd (sl_epj(sk_statd(coo, S_EPOCH))) + + case EQTYPE_ICRS: + call sprintf (wcsstr, maxch, "icrs J%0.3f J%0.8f") + call pargd (sk_statd(coo, S_EQUINOX)) + call pargd (sl_epj(sk_statd(coo, S_EPOCH))) + + case EQTYPE_FK4: + call sprintf (wcsstr, maxch, "fk4 B%0.3f B%0.8f") + call pargd (sk_statd(coo, S_EQUINOX)) + call pargd (sl_epb(sk_statd(coo, S_EPOCH))) + + case EQTYPE_FK4NOE: + call sprintf (wcsstr, maxch, "fk4noe B%0.3f B%0.8f") + call pargd (sk_statd(coo, S_EQUINOX)) + call pargd (sl_epb(sk_statd(coo, S_EPOCH))) + + default: + wcsstr[1] = EOS + } + + case CTYPE_ECLIPTIC: + if (IS_INDEFD(sk_statd(coo, S_EPOCH))) { + call sprintf (wcsstr, maxch, "ecliptic") + } else { + call sprintf (wcsstr, maxch, "ecliptic J%0.8f") + call pargd (sl_epj(sk_statd(coo, S_EPOCH))) + } + + case CTYPE_GALACTIC: + call sprintf (wcsstr, maxch, "galactic J%0.8f") + call pargd (sl_epj(sk_statd(coo, S_EPOCH))) + + case CTYPE_SUPERGALACTIC: + call sprintf (wcsstr, maxch, "supergalactic j%0.8f") + call pargd (sl_epj(sk_statd(coo, S_EPOCH))) + } +end + + +# SK_COPY -- Copy the coodinate structure. + +pointer procedure sk_copy (cooin) + +pointer cooin #I the pointer to the input structure + +pointer cooout + +begin + if (cooin == NULL) + cooout = NULL + else { + call calloc (cooout, LEN_SKYCOOSTRUCT, TY_STRUCT) + SKY_VXOFF(cooout) = SKY_VXOFF(cooin) + SKY_VYOFF(cooout) = SKY_VYOFF(cooin) + SKY_VXSTEP(cooout) = SKY_VXSTEP(cooin) + SKY_VYSTEP(cooout) = SKY_VYSTEP(cooin) + SKY_EQUINOX(cooout) = SKY_EQUINOX(cooin) + SKY_EPOCH(cooout) = SKY_EPOCH(cooin) + SKY_CTYPE(cooout) = SKY_CTYPE(cooin) + SKY_RADECSYS(cooout) = SKY_RADECSYS(cooin) + SKY_WTYPE(cooout) = SKY_WTYPE(cooin) + SKY_PLNGAX(cooout) = SKY_PLNGAX(cooin) + SKY_PLATAX(cooout) = SKY_PLATAX(cooin) + SKY_XLAX(cooout) = SKY_XLAX(cooin) + SKY_YLAX(cooout) = SKY_YLAX(cooin) + SKY_PIXTYPE(cooout) = SKY_PIXTYPE(cooin) + SKY_NLNGAX(cooout) = SKY_NLNGAX(cooin) + SKY_NLATAX(cooout) = SKY_NLATAX(cooin) + SKY_NLNGUNITS(cooout) = SKY_NLNGUNITS(cooin) + SKY_NLATUNITS(cooout) = SKY_NLATUNITS(cooin) + call strcpy (SKY_COOSYSTEM(cooin), SKY_COOSYSTEM(cooout), + SZ_FNAME) + } + + return (cooout) +end + + +# SK_CLOSE -- Free the coordinate structure. + +procedure sk_close (coo) + +pointer coo #U the input coordinate structure + +begin + if (coo != NULL) + call mfree (coo, TY_STRUCT) +end diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/sksaveim.f b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/sksaveim.f new file mode 100644 index 00000000..63e39d30 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/sksaveim.f @@ -0,0 +1,363 @@ + subroutine sksavm (coo, mw, im) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer coo + integer mw + integer im + logical xerpop + logical xerflg + common /xercom/ xerflg + integer sw0001,sw0002 + integer*2 st0001(7) + integer*2 st0002(3) + integer*2 st0003(7) + integer*2 st0004(4) + integer*2 st0005(9) + integer*2 st0006(4) + integer*2 st0007(8) + integer*2 st0008(8) + integer*2 st0009(9) + integer*2 st0010(7) + integer*2 st0011(8) + integer*2 st0012(8) + integer*2 st0013(9) + integer*2 st0014(4) + integer*2 st0015(8) + integer*2 st0016(8) + integer*2 st0017(9) + integer*2 st0018(5) + integer*2 st0019(8) + integer*2 st0020(8) + integer*2 st0021(9) + integer*2 st0022(6) + integer*2 st0023(8) + integer*2 st0024(8) + integer*2 st0025(7) + integer*2 st0026(5) + integer*2 st0027(7) + integer*2 st0028(5) + integer*2 st0029(9) + integer*2 st0030(8) + integer*2 st0031(8) + integer*2 st0032(7) + integer*2 st0033(5) + integer*2 st0034(7) + integer*2 st0035(5) + integer*2 st0036(9) + integer*2 st0037(8) + integer*2 st0038(8) + integer*2 st0039(7) + integer*2 st0040(5) + integer*2 st0041(7) + integer*2 st0042(5) + integer*2 st0043(9) + integer*2 st0044(8) + integer*2 st0045(8) + save + integer iyy + data st0001 / 97,120,116,121,112,101, 0/ + data st0002 /114, 97, 0/ + data st0003 / 97,120,116,121,112,101, 0/ + data st0004 /100,101, 99, 0/ + data (st0005(iyy),iyy= 1, 8) /114, 97,100,101, 99,115,121,115/ + data (st0005(iyy),iyy= 9, 9) / 0/ + data st0006 / 70, 75, 52, 0/ + data st0007 /101,113,117,105,110,111,120, 0/ + data st0008 /109,106,100, 45,119, 99,115, 0/ + data (st0009(iyy),iyy= 1, 8) /114, 97,100,101, 99,115,121,115/ + data (st0009(iyy),iyy= 9, 9) / 0/ + data st0010 / 70, 75, 52, 78, 79, 69, 0/ + data st0011 /101,113,117,105,110,111,120, 0/ + data st0012 /109,106,100, 45,119, 99,115, 0/ + data (st0013(iyy),iyy= 1, 8) /114, 97,100,101, 99,115,121,115/ + data (st0013(iyy),iyy= 9, 9) / 0/ + data st0014 / 70, 75, 53, 0/ + data st0015 /101,113,117,105,110,111,120, 0/ + data st0016 /109,106,100, 45,119, 99,115, 0/ + data (st0017(iyy),iyy= 1, 8) /114, 97,100,101, 99,115,121,115/ + data (st0017(iyy),iyy= 9, 9) / 0/ + data st0018 / 73, 67, 82, 83, 0/ + data st0019 /101,113,117,105,110,111,120, 0/ + data st0020 /109,106,100, 45,119, 99,115, 0/ + data (st0021(iyy),iyy= 1, 8) /114, 97,100,101, 99,115,121,115/ + data (st0021(iyy),iyy= 9, 9) / 0/ + data st0022 / 71, 65, 80, 80, 84, 0/ + data st0023 /101,113,117,105,110,111,120, 0/ + data st0024 /109,106,100, 45,119, 99,115, 0/ + data st0025 / 97,120,116,121,112,101, 0/ + data st0026 /101,108,111,110, 0/ + data st0027 / 97,120,116,121,112,101, 0/ + data st0028 /101,108, 97,116, 0/ + data (st0029(iyy),iyy= 1, 8) /114, 97,100,101, 99,115,121,115/ + data (st0029(iyy),iyy= 9, 9) / 0/ + data st0030 /101,113,117,105,110,111,120, 0/ + data st0031 /109,106,100, 45,119, 99,115, 0/ + data st0032 / 97,120,116,121,112,101, 0/ + data st0033 /103,108,111,110, 0/ + data st0034 / 97,120,116,121,112,101, 0/ + data st0035 /103,108, 97,116, 0/ + data (st0036(iyy),iyy= 1, 8) /114, 97,100,101, 99,115,121,115/ + data (st0036(iyy),iyy= 9, 9) / 0/ + data st0037 /101,113,117,105,110,111,120, 0/ + data st0038 /109,106,100, 45,119, 99,115, 0/ + data st0039 / 97,120,116,121,112,101, 0/ + data st0040 /115,108,111,110, 0/ + data st0041 / 97,120,116,121,112,101, 0/ + data st0042 /115,108, 97,116, 0/ + data (st0043(iyy),iyy= 1, 8) /114, 97,100,101, 99,115,121,115/ + data (st0043(iyy),iyy= 9, 9) / 0/ + data st0044 /101,113,117,105,110,111,120, 0/ + data st0045 /109,106,100, 45,119, 99,115, 0/ + sw0001=(memi(coo+12) ) + goto 110 +120 continue + call mwswas (mw, memi(coo+15) , st0001, st0002) + call mwswas (mw, memi(coo+16) , st0003, st0004) + sw0002=(memi(coo+13) ) + goto 130 +140 continue + call imastr (im, st0005, st0006) + call imaddd (im, st0007, memd((((coo+8)-1)/2+1)) ) + call imaddd (im, st0008, memd((((coo+10)-1)/2+1)) ) + goto 131 +150 continue + call imastr (im, st0009, st0010) + call imaddd (im, st0011, memd((((coo+8)-1)/2+1)) ) + call imaddd (im, st0012, memd((((coo+10)-1)/2+1)) ) + goto 131 +160 continue + call imastr (im, st0013, st0014) + call imaddd (im, st0015, memd((((coo+8)-1)/2+1)) ) + call xerpsh + call imdelf (im, st0016) + if (.not.xerpop()) goto 170 +170 continue + goto 131 +180 continue + call imastr (im, st0017, st0018) + call imaddd (im, st0019, memd((((coo+8)-1)/2+1)) ) + call xerpsh + call imdelf (im, st0020) + if (.not.xerpop()) goto 190 +190 continue + goto 131 +200 continue + call imastr (im, st0021, st0022) + call xerpsh + call imdelf (im, st0023) + if (.not.xerpop()) goto 210 +210 continue + call imaddd (im, st0024, memd((((coo+10)-1)/2+1)) ) + goto 131 +130 continue + if (sw0002.lt.1.or.sw0002.gt.5) goto 131 + goto (140,150,160,180,200),sw0002 +131 continue + goto 111 +220 continue + call mwswas (mw, memi(coo+15) , st0025, st0026) + call mwswas (mw, memi(coo+16) , st0027, st0028) + call xerpsh + call imdelf (im, st0029) + if (.not.xerpop()) goto 230 +230 continue + call xerpsh + call imdelf (im, st0030) + if (.not.xerpop()) goto 240 +240 continue + call imaddd (im, st0031, memd((((coo+10)-1)/2+1)) ) + goto 111 +250 continue + call mwswas (mw, memi(coo+15) , st0032, st0033) + call mwswas (mw, memi(coo+16) , st0034, st0035) + call xerpsh + call imdelf (im, st0036) + if (.not.xerpop()) goto 260 +260 continue + call xerpsh + call imdelf (im, st0037) + if (.not.xerpop()) goto 270 +270 continue + call xerpsh + call imdelf (im, st0038) + if (.not.xerpop()) goto 280 +280 continue + goto 111 +290 continue + call mwswas (mw, memi(coo+15) , st0039, st0040) + call mwswas (mw, memi(coo+16) , st0041, st0042) + call xerpsh + call imdelf (im, st0043) + if (.not.xerpop()) goto 300 +300 continue + call xerpsh + call imdelf (im, st0044) + if (.not.xerpop()) goto 310 +310 continue + call xerpsh + call imdelf (im, st0045) + if (.not.xerpop()) goto 320 +320 continue + goto 111 +110 continue + if (sw0001.lt.1.or.sw0001.gt.4) goto 111 + goto (120,220,250,290),sw0001 +111 continue +100 return + end + subroutine skctym (coo, im) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer coo + integer im + integer sp + integer wtype + integer key1 + integer key2 + integer attr + integer skwrdr + integer sw0001 + integer*2 st0001(8) + integer*2 st0002(8) + integer*2 st0003(7) + integer*2 st0004(7) + integer*2 st0005(114) + integer*2 st0006(4) + integer*2 st0007(9) + integer*2 st0008(9) + integer*2 st0009(9) + integer*2 st0010(9) + integer*2 st0011(9) + integer*2 st0012(9) + integer*2 st0013(9) + integer*2 st0014(9) + integer*2 st0015(7) + integer*2 st0016(7) + save + integer iyy + data st0001 / 67, 84, 89, 80, 69, 37,100, 0/ + data st0002 / 67, 84, 89, 80, 69, 37,100, 0/ + data st0003 / 76, 73, 78, 69, 65, 82, 0/ + data st0004 / 76, 73, 78, 69, 65, 82, 0/ + data (st0005(iyy),iyy= 1, 8) /124,108,105,110,124, 97,122,112/ + data (st0005(iyy),iyy= 9,16) /124,116, 97,110,124,115,105,110/ + data (st0005(iyy),iyy=17,24) /124,115,116,103,124, 97,114, 99/ + data (st0005(iyy),iyy=25,32) /124,122,112,110,124,122,101, 97/ + data (st0005(iyy),iyy=33,40) /124, 97,105,114,124, 99,121,112/ + data (st0005(iyy),iyy=41,48) /124, 99, 97,114,124,109,101,114/ + data (st0005(iyy),iyy=49,56) /124, 99,101, 97,124, 99,111,112/ + data (st0005(iyy),iyy=57,64) /124, 99,111,100,124, 99,111,101/ + data (st0005(iyy),iyy=65,72) /124, 99,111,111,124, 98,111,110/ + data (st0005(iyy),iyy=73,80) /124,112, 99,111,124,103,108,115/ + data (st0005(iyy),iyy=81,88) /124,112, 97,114,124, 97,105,116/ + data (st0005(iyy),iyy=89,96) /124,109,111,108,124, 99,115, 99/ + data (st0005(iyy),iyy=97,104) /124,113,115, 99,124,116,115, 99/ + data (st0005(iyy),iyy=105,112) /124,116,110,120,124,122,112,120/ + data (st0005(iyy),iyy=113,114) /124, 0/ + data st0006 /116, 97,110, 0/ + data (st0007(iyy),iyy= 1, 8) / 82, 65, 45, 45, 45, 37, 51,115/ + data (st0007(iyy),iyy= 9, 9) / 0/ + data (st0008(iyy),iyy= 1, 8) / 68, 69, 67, 45, 45, 37, 51,115/ + data (st0008(iyy),iyy= 9, 9) / 0/ + data (st0009(iyy),iyy= 1, 8) / 69, 76, 79, 78, 45, 37, 51,115/ + data (st0009(iyy),iyy= 9, 9) / 0/ + data (st0010(iyy),iyy= 1, 8) / 69, 76, 65, 84, 45, 37, 51,115/ + data (st0010(iyy),iyy= 9, 9) / 0/ + data (st0011(iyy),iyy= 1, 8) / 71, 76, 79, 78, 45, 37, 51,115/ + data (st0011(iyy),iyy= 9, 9) / 0/ + data (st0012(iyy),iyy= 1, 8) / 71, 76, 65, 84, 45, 37, 51,115/ + data (st0012(iyy),iyy= 9, 9) / 0/ + data (st0013(iyy),iyy= 1, 8) / 83, 76, 79, 78, 45, 37, 51,115/ + data (st0013(iyy),iyy= 9, 9) / 0/ + data (st0014(iyy),iyy= 1, 8) / 83, 76, 65, 84, 45, 37, 51,115/ + data (st0014(iyy),iyy= 9, 9) / 0/ + data st0015 / 76, 73, 78, 69, 65, 82, 0/ + data st0016 / 76, 73, 78, 69, 65, 82, 0/ + call smark (sp) + call salloc (key1, 8, 2) + call salloc (key2, 8, 2) + call salloc (wtype, 3, 2) + call salloc (attr, 8, 2) + call sprinf (memc(key1), 8, st0001) + call pargi (memi(coo+15) ) + call sprinf (memc(key2), 8, st0002) + call pargi (memi(coo+16) ) + if (.not.(memi(coo+14) .le. 0 .or. memi(coo+14) .eq. 1)) goto + * 110 + call imastr (im, memc(key1), st0003) + call imastr (im, memc(key2), st0004) + call sfree (sp) + goto 100 +110 continue + if (.not.(skwrdr (memi(coo+14) , memc(wtype), 3, st0005) .le. 0 + * )) goto 120 + call xstrcy(st0006, memc(wtype), 3) +120 continue + call strupr (memc(wtype)) + sw0001=(memi(coo+12) ) + goto 130 +140 continue + call sprinf (memc(attr), 8, st0007) + call pargsr (memc(wtype)) + call imastr (im, memc(key1), memc(attr)) + call sprinf (memc(attr), 8, st0008) + call pargsr (memc(wtype)) + call imastr (im, memc(key2), memc(attr)) + goto 131 +150 continue + call sprinf (memc(attr), 8, st0009) + call pargsr (memc(wtype)) + call imastr (im, memc(key1), memc(attr)) + call sprinf (memc(attr), 8, st0010) + call pargsr (memc(wtype)) + call imastr (im, memc(key2), memc(attr)) + goto 131 +160 continue + call sprinf (memc(attr), 8, st0011) + call pargsr (memc(wtype)) + call imastr (im, memc(key1), memc(attr)) + call sprinf (memc(attr), 8, st0012) + call pargsr (memc(wtype)) + call imastr (im, memc(key2), memc(attr)) + goto 131 +170 continue + call sprinf (memc(attr), 8, st0013) + call pargsr (memc(wtype)) + call imastr (im, memc(key1), memc(attr)) + call sprinf (memc(attr), 8, st0014) + call pargsr (memc(wtype)) + call imastr (im, memc(key2), memc(attr)) + goto 131 +180 continue + call imastr (im, memc(key1), st0015) + call imastr (im, memc(key2), st0016) + goto 131 +130 continue + if (sw0001.lt.1.or.sw0001.gt.4) goto 180 + goto (140,150,160,170),sw0001 +131 continue + call sfree (sp) +100 return + end +c sprinf sprintf +c skctym sk_ctypeim +c skwrdr sk_wrdstr +c sksavm sk_saveim +c mwswas mw_swattrs +c pargsr pargstr diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/sksaveim.x b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/sksaveim.x new file mode 100644 index 00000000..77b5a1d9 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/sksaveim.x @@ -0,0 +1,157 @@ +include "skywcsdef.h" +include "skywcs.h" + +# SK_SAVEIM -- Update the image header keywords that describe the +# fundamental coordinate system, CTYPE, RADECSYS, EQUINOX (EPOCH), and +# MJD-WCS. + +procedure sk_saveim (coo, mw, im) + +pointer coo #I pointer to the coordinate structure +pointer mw #I pointer to the mwcs structure +pointer im #I image descriptor + +errchk imdelf() + +begin + # Move all this to a separate routine + switch (SKY_CTYPE(coo)) { + + case CTYPE_EQUATORIAL: + call mw_swattrs (mw, SKY_PLNGAX(coo), "axtype", "ra") + call mw_swattrs (mw, SKY_PLATAX(coo), "axtype", "dec") + switch (SKY_RADECSYS(coo)) { + case EQTYPE_FK4: + call imastr (im, "radecsys", "FK4") + call imaddd (im, "equinox", SKY_EQUINOX(coo)) + call imaddd (im, "mjd-wcs", SKY_EPOCH(coo)) + case EQTYPE_FK4NOE: + call imastr (im, "radecsys", "FK4NOE") + call imaddd (im, "equinox", SKY_EQUINOX(coo)) + call imaddd (im, "mjd-wcs", SKY_EPOCH(coo)) + case EQTYPE_FK5: + call imastr (im, "radecsys", "FK5") + call imaddd (im, "equinox", SKY_EQUINOX(coo)) + iferr (call imdelf (im, "mjd-wcs")) + ; + case EQTYPE_ICRS: + call imastr (im, "radecsys", "ICRS") + call imaddd (im, "equinox", SKY_EQUINOX(coo)) + iferr (call imdelf (im, "mjd-wcs")) + ; + case EQTYPE_GAPPT: + call imastr (im, "radecsys", "GAPPT") + iferr (call imdelf (im, "equinox")) + ; + call imaddd (im, "mjd-wcs", SKY_EPOCH(coo)) + } + + case CTYPE_ECLIPTIC: + call mw_swattrs (mw, SKY_PLNGAX(coo), "axtype", "elon") + call mw_swattrs (mw, SKY_PLATAX(coo), "axtype", "elat") + iferr (call imdelf (im, "radecsys")) + ; + iferr (call imdelf (im, "equinox")) + ; + call imaddd (im, "mjd-wcs", SKY_EPOCH(coo)) + + case CTYPE_GALACTIC: + call mw_swattrs (mw, SKY_PLNGAX(coo), "axtype", "glon") + call mw_swattrs (mw, SKY_PLATAX(coo), "axtype", "glat") + iferr (call imdelf (im, "radecsys")) + ; + iferr (call imdelf (im, "equinox")) + ; + iferr (call imdelf (im, "mjd-wcs")) + ; + + case CTYPE_SUPERGALACTIC: + call mw_swattrs (mw, SKY_PLNGAX(coo), "axtype", "slon") + call mw_swattrs (mw, SKY_PLATAX(coo), "axtype", "slat") + iferr (call imdelf (im, "radecsys")) + ; + iferr (call imdelf (im, "equinox")) + ; + iferr (call imdelf (im, "mjd-wcs")) + ; + } +end + + +# SK_CTYPEIM -- Modify the CTYPE keywords appropriately. This step will +# become unnecessary when MWCS is updated to deal with non-equatorial celestial +# coordinate systems. + +procedure sk_ctypeim (coo, im) + +pointer coo #I pointer to the coordinate structure +pointer im #I image descriptor + +pointer sp, wtype, key1, key2, attr +int sk_wrdstr() + +begin + call smark (sp) + call salloc (key1, 8, TY_CHAR) + call salloc (key2, 8, TY_CHAR) + call salloc (wtype, 3, TY_CHAR) + call salloc (attr, 8, TY_CHAR) + + call sprintf (Memc[key1], 8, "CTYPE%d") + call pargi (SKY_PLNGAX(coo)) + call sprintf (Memc[key2], 8, "CTYPE%d") + call pargi (SKY_PLATAX(coo)) + + if (SKY_WTYPE(coo) <= 0 || SKY_WTYPE(coo) == WTYPE_LIN) { + call imastr (im, Memc[key1], "LINEAR") + call imastr (im, Memc[key2], "LINEAR") + call sfree (sp) + return + } + + if (sk_wrdstr (SKY_WTYPE(coo), Memc[wtype], 3, WTYPE_LIST) <= 0) + call strcpy ("tan", Memc[wtype], 3) + call strupr (Memc[wtype]) + + # Move all this to a separate routine + switch (SKY_CTYPE(coo)) { + + case CTYPE_EQUATORIAL: + call sprintf (Memc[attr], 8, "RA---%3s") + call pargstr (Memc[wtype]) + call imastr (im, Memc[key1], Memc[attr]) + call sprintf (Memc[attr], 8, "DEC--%3s") + call pargstr (Memc[wtype]) + call imastr (im, Memc[key2], Memc[attr]) + + case CTYPE_ECLIPTIC: + call sprintf (Memc[attr], 8, "ELON-%3s") + call pargstr (Memc[wtype]) + call imastr (im, Memc[key1], Memc[attr]) + call sprintf (Memc[attr], 8, "ELAT-%3s") + call pargstr (Memc[wtype]) + call imastr (im, Memc[key2], Memc[attr]) + + case CTYPE_GALACTIC: + call sprintf (Memc[attr], 8, "GLON-%3s") + call pargstr (Memc[wtype]) + call imastr (im, Memc[key1], Memc[attr]) + call sprintf (Memc[attr], 8, "GLAT-%3s") + call pargstr (Memc[wtype]) + call imastr (im, Memc[key2], Memc[attr]) + + case CTYPE_SUPERGALACTIC: + call sprintf (Memc[attr], 8, "SLON-%3s") + call pargstr (Memc[wtype]) + call imastr (im, Memc[key1], Memc[attr]) + call sprintf (Memc[attr], 8, "SLAT-%3s") + call pargstr (Memc[wtype]) + call imastr (im, Memc[key2], Memc[attr]) + + default: + call imastr (im, Memc[key1], "LINEAR") + call imastr (im, Memc[key2], "LINEAR") + } + + call sfree (sp) +end diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skset.f b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skset.f new file mode 100644 index 00000000..65765222 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skset.f @@ -0,0 +1,179 @@ + subroutine sksetd (coo, param, value) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer coo + integer param + double precision value + logical xerflg + common /xercom/ xerflg + integer sw0001 + integer*2 st0001(46) + save + integer iyy + data (st0001(iyy),iyy= 1, 8) / 83, 75, 89, 95, 83, 69, 84, 68/ + data (st0001(iyy),iyy= 9,16) / 58, 32, 85,110,107,110,111,119/ + data (st0001(iyy),iyy=17,24) /110, 32, 99,111,111,114,100,105/ + data (st0001(iyy),iyy=25,32) /110, 97,116,101, 32,115,121,115/ + data (st0001(iyy),iyy=33,40) /116,101,109, 32,112, 97,114, 97/ + data (st0001(iyy),iyy=41,46) /109,101,116,101,114, 0/ + sw0001=(param) + goto 110 +120 continue + memd((((coo)-1)/2+1)) = value + goto 111 +130 continue + memd((((coo+2)-1)/2+1)) = value + goto 111 +140 continue + memd((((coo+4)-1)/2+1)) = value + goto 111 +150 continue + memd((((coo+6)-1)/2+1)) = value + goto 111 +160 continue + memd((((coo+8)-1)/2+1)) = value + goto 111 +170 continue + memd((((coo+10)-1)/2+1)) = value + goto 111 +180 continue + call xerror(0, st0001) + if (xerflg) goto 100 + goto 111 +110 continue + if (sw0001.lt.1.or.sw0001.gt.6) goto 180 + goto (120,130,140,150,160,170),sw0001 +111 continue +100 return + end + subroutine skseti (coo, param, value) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer coo + integer param + integer value + logical xerflg + common /xercom/ xerflg + integer sw0001 + integer*2 st0001(46) + save + integer iyy + data (st0001(iyy),iyy= 1, 8) / 83, 75, 89, 95, 83, 69, 84, 73/ + data (st0001(iyy),iyy= 9,16) / 58, 32, 85,110,107,110,111,119/ + data (st0001(iyy),iyy=17,24) /110, 32, 99,111,111,114,100,105/ + data (st0001(iyy),iyy=25,32) /110, 97,116,101, 32,115,121,115/ + data (st0001(iyy),iyy=33,40) /116,101,109, 32,112, 97,114, 97/ + data (st0001(iyy),iyy=41,46) /109,101,116,101,114, 0/ + sw0001=(param) + goto 110 +120 continue + memi(coo+12) = value + goto 111 +130 continue + memi(coo+13) = value + goto 111 +140 continue + memi(coo+14) = value + goto 111 +150 continue + memi(coo+15) = value + goto 111 +160 continue + memi(coo+16) = value + goto 111 +170 continue + memi(coo+17) = value + goto 111 +180 continue + memi(coo+18) = value + goto 111 +190 continue + memi(coo+19) = value + goto 111 +200 continue + memi(coo+20) = value + goto 111 +210 continue + memi(coo+21) = value + goto 111 +220 continue + memi(coo+22) = value + goto 111 +230 continue + memi(coo+23) = value + goto 111 +240 continue + memi(coo+24) = value + goto 111 +250 continue + call xerror(0, st0001) + if (xerflg) goto 100 + goto 111 +110 continue + sw0001=sw0001-6 + if (sw0001.lt.1.or.sw0001.gt.14) goto 250 + goto (120,130,140,150,160,170,180,190,200,210,220,230,250, + * 240),sw0001 +111 continue +100 return + end + subroutine sksets (coo, param, value) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer coo + integer param + integer*2 value(*) + logical xerflg + common /xercom/ xerflg + integer sw0001 + integer*2 st0001(48) + save + integer iyy + data (st0001(iyy),iyy= 1, 8) / 83, 75, 89, 95, 83, 69, 84, 83/ + data (st0001(iyy),iyy= 9,16) / 84, 82, 58, 32, 85,110,107,110/ + data (st0001(iyy),iyy=17,24) /111,119,110, 32, 99,111,111,114/ + data (st0001(iyy),iyy=25,32) /100,105,110, 97,116,101, 32,115/ + data (st0001(iyy),iyy=33,40) /121,115,116,101,109, 32,112, 97/ + data (st0001(iyy),iyy=41,48) /114, 97,109,101,116,101,114, 0/ + sw0001=(param) + goto 110 +120 continue + call xstrcy(value, memc((((coo+25)-1)*2+1)) , 255 ) + goto 111 +130 continue + call xerror(0, st0001) + if (xerflg) goto 100 + goto 111 +110 continue + if (sw0001.eq.19) goto 120 + goto 130 +111 continue +100 return + end +c sksetd sk_setd +c skseti sk_seti +c sksets sk_sets diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skset.x b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skset.x new file mode 100644 index 00000000..9e7191c3 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skset.x @@ -0,0 +1,90 @@ +include "skywcsdef.h" +include "skywcs.h" + + +# SK_SETD -- Set a double precision coordinate parameter. + +procedure sk_setd (coo, param, value) + +pointer coo #I pointer to the coordinate structure +int param #I the input parameter +double value #I the parameter value + +begin + switch (param) { + case S_VXOFF: + SKY_VXOFF(coo) = value + case S_VYOFF: + SKY_VYOFF(coo) = value + case S_VXSTEP: + SKY_VXSTEP(coo) = value + case S_VYSTEP: + SKY_VYSTEP(coo) = value + case S_EQUINOX: + SKY_EQUINOX(coo) = value + case S_EPOCH: + SKY_EPOCH(coo) = value + default: + call error (0, "SKY_SETD: Unknown coordinate system parameter") + } +end + + +# SK_SETI -- Set an integer coordinate parameter. + +procedure sk_seti (coo, param, value) + +pointer coo #I pointer to the coordinate structure +int param #I the input parameter +int value #I the parameter value + +begin + switch (param) { + case S_CTYPE: + SKY_CTYPE(coo) = value + case S_RADECSYS: + SKY_RADECSYS(coo) = value + case S_WTYPE: + SKY_WTYPE(coo) = value + case S_PLNGAX: + SKY_PLNGAX(coo) = value + case S_PLATAX: + SKY_PLATAX(coo) = value + case S_XLAX: + SKY_XLAX(coo) = value + case S_YLAX: + SKY_YLAX(coo) = value + case S_PIXTYPE: + SKY_PIXTYPE(coo) = value + case S_NLNGAX: + SKY_NLNGAX(coo) = value + case S_NLATAX: + SKY_NLATAX(coo) = value + case S_NLNGUNITS: + SKY_NLNGUNITS(coo) = value + case S_NLATUNITS: + SKY_NLATUNITS(coo) = value + case S_STATUS: + SKY_STATUS(coo) = value + default: + call error (0, "SKY_SETI: Unknown coordinate system parameter") + } +end + + +# SK_SETS -- Set a character string coordinate parameter. + +procedure sk_sets (coo, param, value) + +pointer coo #I pointer to the coordinate structure +int param #I the input parameter +char value[ARB] #I the parameter value + +begin + switch (param) { + case S_COOSYSTEM: + call strcpy (value, SKY_COOSYSTEM(coo), SZ_FNAME) + default: + call error (0, "SKY_SETSTR: Unknown coordinate system parameter") + } +end diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skstat.f b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skstat.f new file mode 100644 index 00000000..4c3c8397 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skstat.f @@ -0,0 +1,179 @@ + double precision function skstad (coo, param) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer coo + integer param + logical xerflg + common /xercom/ xerflg + integer sw0001 + integer*2 st0001(47) + save + integer iyy + data (st0001(iyy),iyy= 1, 8) / 83, 75, 89, 95, 83, 84, 65, 84/ + data (st0001(iyy),iyy= 9,16) / 68, 58, 32, 85,110,107,110,111/ + data (st0001(iyy),iyy=17,24) /119,110, 32, 99,111,111,114,100/ + data (st0001(iyy),iyy=25,32) /105,110, 97,116,101, 32,115,121/ + data (st0001(iyy),iyy=33,40) /115,116,101,109, 32,112, 97,114/ + data (st0001(iyy),iyy=41,47) / 97,109,101,116,101,114, 0/ + skstad = 0 + sw0001=(param) + goto 110 +120 continue + skstad = (memd((((coo)-1)/2+1)) ) + goto 100 +130 continue + skstad = (memd((((coo+2)-1)/2+1)) ) + goto 100 +140 continue + skstad = (memd((((coo+4)-1)/2+1)) ) + goto 100 +150 continue + skstad = (memd((((coo+6)-1)/2+1)) ) + goto 100 +160 continue + skstad = (memd((((coo+8)-1)/2+1)) ) + goto 100 +170 continue + skstad = (memd((((coo+10)-1)/2+1)) ) + goto 100 +180 continue + call xerror(0, st0001) + if (xerflg) goto 100 + goto 111 +110 continue + if (sw0001.lt.1.or.sw0001.gt.6) goto 180 + goto (120,130,140,150,160,170),sw0001 +111 continue +100 return + end + integer function skstai (coo, param) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer coo + integer param + logical xerflg + common /xercom/ xerflg + integer sw0001 + integer*2 st0001(47) + save + integer iyy + data (st0001(iyy),iyy= 1, 8) / 83, 75, 89, 95, 83, 84, 65, 84/ + data (st0001(iyy),iyy= 9,16) / 73, 58, 32, 85,110,107,110,111/ + data (st0001(iyy),iyy=17,24) /119,110, 32, 99,111,111,114,100/ + data (st0001(iyy),iyy=25,32) /105,110, 97,116,101, 32,115,121/ + data (st0001(iyy),iyy=33,40) /115,116,101,109, 32,112, 97,114/ + data (st0001(iyy),iyy=41,47) / 97,109,101,116,101,114, 0/ + sw0001=(param) + goto 110 +120 continue + skstai = (memi(coo+12) ) + goto 100 +130 continue + skstai = (memi(coo+13) ) + goto 100 +140 continue + skstai = (memi(coo+14) ) + goto 100 +150 continue + skstai = (memi(coo+15) ) + goto 100 +160 continue + skstai = (memi(coo+16) ) + goto 100 +170 continue + skstai = (memi(coo+17) ) + goto 100 +180 continue + skstai = (memi(coo+18) ) + goto 100 +190 continue + skstai = (memi(coo+19) ) + goto 100 +200 continue + skstai = (memi(coo+20) ) + goto 100 +210 continue + skstai = (memi(coo+21) ) + goto 100 +220 continue + skstai = (memi(coo+22) ) + goto 100 +230 continue + skstai = (memi(coo+23) ) + goto 100 +240 continue + skstai = (memi(coo+24) ) + goto 100 +250 continue + call xerror(0, st0001) + if (xerflg) goto 100 + goto 111 +110 continue + sw0001=sw0001-6 + if (sw0001.lt.1.or.sw0001.gt.14) goto 250 + goto (120,130,140,150,160,170,180,190,200,210,220,230,250, + * 240),sw0001 +111 continue +100 return + end + subroutine skstas (coo, param, value, maxch) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer coo + integer param + integer*2 value + integer maxch + logical xerflg + common /xercom/ xerflg + integer sw0001 + integer*2 st0001(48) + save + integer iyy + data (st0001(iyy),iyy= 1, 8) / 83, 75, 89, 95, 71, 69, 84, 83/ + data (st0001(iyy),iyy= 9,16) / 84, 82, 58, 32, 85,110,107,110/ + data (st0001(iyy),iyy=17,24) /111,119,110, 32, 99,111,111,114/ + data (st0001(iyy),iyy=25,32) /100,105,110, 97,116,101, 32,115/ + data (st0001(iyy),iyy=33,40) /121,115,116,101,109, 32,112, 97/ + data (st0001(iyy),iyy=41,48) /114, 97,109,101,116,101,114, 0/ + sw0001=(param) + goto 110 +120 continue + call xstrcy(memc((((coo+25)-1)*2+1)) , value, maxch) + goto 111 +130 continue + call xerror(0, st0001) + if (xerflg) goto 100 + goto 111 +110 continue + if (sw0001.eq.19) goto 120 + goto 130 +111 continue +100 return + end +c skstad sk_statd +c skstai sk_stati +c skstas sk_stats diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skstat.x b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skstat.x new file mode 100644 index 00000000..82d2f1c2 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skstat.x @@ -0,0 +1,90 @@ +include "skywcsdef.h" +include "skywcs.h" + + +# SK_STATD -- Get a double precision coordinate parameter. + +double procedure sk_statd (coo, param) + +pointer coo #I pointer to the coordinate structure +int param #I the input parameter + +begin + switch (param) { + case S_VXOFF: + return (SKY_VXOFF(coo)) + case S_VYOFF: + return (SKY_VYOFF(coo)) + case S_VXSTEP: + return (SKY_VXSTEP(coo)) + case S_VYSTEP: + return (SKY_VYSTEP(coo)) + case S_EQUINOX: + return (SKY_EQUINOX(coo)) + case S_EPOCH: + return (SKY_EPOCH(coo)) + default: + call error (0, "SKY_STATD: Unknown coordinate system parameter") + } +end + + +# SK_STATI -- Get an integer coordinate parameter. + +int procedure sk_stati (coo, param) + +pointer coo #I pointer to the coordinate structure +int param #I the input parameter + +begin + switch (param) { + case S_CTYPE: + return (SKY_CTYPE(coo)) + case S_RADECSYS: + return (SKY_RADECSYS(coo)) + case S_WTYPE: + return (SKY_WTYPE(coo)) + case S_PLNGAX: + return (SKY_PLNGAX(coo)) + case S_PLATAX: + return (SKY_PLATAX(coo)) + case S_XLAX: + return (SKY_XLAX(coo)) + case S_YLAX: + return (SKY_YLAX(coo)) + case S_PIXTYPE: + return (SKY_PIXTYPE(coo)) + case S_NLNGAX: + return (SKY_NLNGAX(coo)) + case S_NLATAX: + return (SKY_NLATAX(coo)) + case S_NLNGUNITS: + return (SKY_NLNGUNITS(coo)) + case S_NLATUNITS: + return (SKY_NLATUNITS(coo)) + case S_STATUS: + return (SKY_STATUS(coo)) + default: + call error (0, "SKY_STATI: Unknown coordinate system parameter") + } +end + + + +# SK_STATS -- Get a character string coordinate parameter. + +procedure sk_stats (coo, param, value, maxch) + +pointer coo #I pointer to the coordinate structure +int param #I the input parameter +char value #O the output string +int maxch #I the maximum size of the string + +begin + switch (param) { + case S_COOSYSTEM: + call strcpy (SKY_COOSYSTEM(coo), value, maxch) + default: + call error (0, "SKY_GETSTR: Unknown coordinate system parameter") + } +end diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/sktransform.f b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/sktransform.f new file mode 100644 index 00000000..85aff7b1 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/sktransform.f @@ -0,0 +1,756 @@ + subroutine skultn (cooin, cooout, ilng, ilat, olng, olat, npts) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer cooin + integer cooout + integer npts + double precision ilng(*) + double precision ilat(*) + double precision olng(*) + double precision olat(*) + double precision tilng + double precision tilat + double precision tolng + double precision tolat + integer i + integer sw0001,sw0002,sw0003,sw0004 + save + do 110 i = 1, npts + sw0001=(memi(cooin+22) ) + goto 120 +130 continue + tilng = ((15.0d0 * ilng(i))/57.295779513082320877) + goto 121 +140 continue + tilng = ((ilng(i))/57.295779513082320877) + goto 121 +150 continue + tilng = ilng(i) + goto 121 +160 continue + tilng = ilng(i) + goto 121 +120 continue + if (sw0001.lt.1.or.sw0001.gt.3) goto 160 + goto (140,150,130),sw0001 +121 continue + sw0002=(memi(cooin+23) ) + goto 170 +180 continue + tilat = ((15.0d0 * ilat(i))/57.295779513082320877) + goto 171 +190 continue + tilat = ((ilat(i))/57.295779513082320877) + goto 171 +200 continue + tilat = ilat(i) + goto 171 +210 continue + tilat = ilat(i) + goto 171 +170 continue + if (sw0002.lt.1.or.sw0002.gt.3) goto 210 + goto (190,200,180),sw0002 +171 continue + call sklltn (cooin, cooout, tilng, tilat, 1.6d308, 1.6d308, + * 0.0d0, 0.0d0, tolng, tolat) + sw0003=(memi(cooout+22) ) + goto 220 +230 continue + olng(i) = ((tolng)*57.295779513082320877) / 15.0d0 + goto 221 +240 continue + olng(i) = ((tolng)*57.295779513082320877) + goto 221 +250 continue + olng(i) = tolng + goto 221 +260 continue + olng(i) = tolng + goto 221 +220 continue + if (sw0003.lt.1.or.sw0003.gt.3) goto 260 + goto (240,250,230),sw0003 +221 continue + sw0004=(memi(cooout+23) ) + goto 270 +280 continue + olat(i) = ((tolat)*57.295779513082320877) / 15.0d0 + goto 271 +290 continue + olat(i) = ((tolat)*57.295779513082320877) + goto 271 +300 continue + olat(i) = tolat + goto 271 +310 continue + olat(i) = tolat + goto 271 +270 continue + if (sw0004.lt.1.or.sw0004.gt.3) goto 310 + goto (290,300,280),sw0004 +271 continue +110 continue +111 continue +100 return + end + subroutine sklltn (cooin, cooout, ilng, ilat, ipmlng, ipmlat, px, + *rv, olng, olat) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer cooin + integer cooout + double precision ilng + double precision ilat + double precision ipmlng + double precision ipmlat + double precision px + double precision rv + double precision olng + double precision olat + integer pmflag + double precision pmr + double precision pmd + double precision slepj + double precision slepb + integer sw0001,sw0002,sw0003,sw0004,sw0005,sw0006,sw0007,sw0008, + *sw0009,sw0010 + save + if (.not.(memi(cooin+12) .eq. memi(cooout+12) )) goto 110 + sw0001=(memi(cooin+12) ) + goto 120 +130 continue + call skequl (cooin, cooout, ilng, ilat, ipmlng, ipmlat, + * px, rv, olng, olat) + goto 121 +140 continue + if (.not.(memd((((cooin+10)-1)/2+1)) .eq. memd((((cooout+ + * 10)-1)/2+1)) )) goto 150 + olng = ilng + olat = ilat + goto 151 +150 continue + call sleceq (ilng, ilat, memd((((cooin+10)-1)/2+1)) , + * olng, olat) + call sleqec (olng, olat, memd((((cooout+10)-1)/2+1)) , + * olng, olat) +151 continue + goto 121 +160 continue + olng = ilng + olat = ilat + goto 121 +120 continue + if (sw0001.eq.1) goto 130 + if (sw0001.eq.2) goto 140 + goto 160 +121 continue + goto 100 +110 continue + if (.not.(.not. ((ipmlng).eq.1.6d308) .and. .not. ((ipmlat).eq. + * 1.6d308))) goto 170 + pmflag = 1 + goto 171 +170 continue + pmflag = 0 +171 continue + sw0002=(memi(cooin+12) ) + goto 180 +190 continue + sw0003=(memi(cooin+13) ) + goto 200 +210 continue + if (.not.(pmflag .eq. 1)) goto 220 + call slpm (ilng, ilat, ipmlng, ipmlat, px, rv, slepb ( + * memd((((cooin+10)-1)/2+1)) ), slepb (memd((((cooout+10 + * )-1)/2+1)) ), olng, olat) + goto 221 +220 continue + olng = ilng + olat = ilat +221 continue + if (.not.(memi(cooin+13) .eq. 1)) goto 230 + call slsuet (olng, olat, memd((((cooin+8)-1)/2+1)) , + * olng, olat) +230 continue + if (.not.(memd((((cooin+8)-1)/2+1)) .ne. 1950.0d0)) goto + * 240 + call slprcs (1, memd((((cooin+8)-1)/2+1)) , 1950.0d0, + * olng, olat) +240 continue + call sladet (olng, olat, 1950.0d0, olng, olat) + if (.not.(pmflag .eq. 1)) goto 250 + call slf45z (olng, olat, slepb(memd((((cooout+10)-1)/2 + * +1)) ), olng, olat) + goto 251 +250 continue + call slf45z (olng, olat, slepb (memd((((cooin+10)-1)/2 + * +1)) ), olng, olat) +251 continue + goto 201 +260 continue + if (.not.(pmflag .eq. 1)) goto 270 + call slpm (ilng, ilat, ipmlng, ipmlat, px, rv, slepj ( + * memd((((cooin+10)-1)/2+1)) ), slepj(memd((((cooout+10) + * -1)/2+1)) ), olng, olat) + goto 271 +270 continue + olng = ilng + olat = ilat +271 continue + if (.not.(memd((((cooin+8)-1)/2+1)) .ne. 2000.0d0)) goto + * 280 + call slprcs (2, memd((((cooin+8)-1)/2+1)) , 2000.0d0, + * olng, olat) +280 continue + goto 201 +290 continue + if (.not.(pmflag .eq. 1)) goto 300 + call slpm (ilng, ilat, ipmlng, ipmlat, px, rv, slepj ( + * memd((((cooin+10)-1)/2+1)) ), slepj(memd((((cooout+10) + * -1)/2+1)) ), olng, olat) + goto 301 +300 continue + olng = ilng + olat = ilat +301 continue + if (.not.(memd((((cooin+8)-1)/2+1)) .ne. 2000.0d0)) goto + * 310 + call slprcs (2, memd((((cooin+8)-1)/2+1)) , 2000.0d0, + * olng, olat) +310 continue + call slhf5z (olng, olat, 2000.0d0, olng, olat, pmr, pmd) + goto 201 +320 continue + call slamp (ilng, ilat, memd((((cooin+10)-1)/2+1)) , 2000 + * .0d0, olng, olat) + goto 201 +200 continue + if (sw0003.lt.1.or.sw0003.gt.5) goto 201 + goto (210,210,260,290,320),sw0003 +201 continue + sw0004=(memi(cooout+12) ) + goto 330 +340 continue + call sleqec (olng, olat, memd((((cooout+10)-1)/2+1)) , + * olng, olat) + goto 331 +350 continue + call sleqga (olng, olat, olng, olat) + goto 331 +360 continue + call sleqga (olng, olat, olng, olat) + call slgasu (olng, olat, olng, olat) + goto 331 +370 continue + olng = ilng + olat = ilat + goto 331 +330 continue + sw0004=sw0004-1 + if (sw0004.lt.1.or.sw0004.gt.3) goto 370 + goto (340,350,360),sw0004 +331 continue + goto 181 +380 continue + call sleceq (ilng, ilat, memd((((cooin+10)-1)/2+1)) , olng, + * olat) + sw0005=(memi(cooout+12) ) + goto 390 +400 continue + sw0006=(memi(cooout+13) ) + goto 410 +420 continue + call slf54z (olng, olat, slepb(memd((((cooout+10)-1)/2 + * +1)) ), olng, olat, pmr, pmd) + call slsuet (olng, olat, 1950.0d0, olng, olat) + if (.not.(memd((((cooout+8)-1)/2+1)) .ne. 1950.0d0)) + * goto 430 + call slprcs (1, 1950.0d0, memd((((cooout+8)-1)/2+1) + * ) , olng, olat) +430 continue + if (.not.(memi(cooout+13) .eq. 1)) goto 440 + call sladet (olng, olat, memd((((cooout+8)-1)/2+1)) + * , olng, olat) +440 continue + goto 411 +450 continue + if (.not.(memd((((cooout+8)-1)/2+1)) .ne. 2000.0d0)) + * goto 460 + call slprcs (2, 2000.0d0, memd((((cooout+8)-1)/2+1) + * ) , olng, olat) +460 continue + goto 411 +470 continue + call slf5hz (olng, olat, 2000.0d0, olng, olat) + if (.not.(memd((((cooout+8)-1)/2+1)) .ne. 2000.0d0)) + * goto 480 + call slprcs (2, 2000.0d0, memd((((cooout+8)-1)/2+1) + * ) , olng, olat) +480 continue + goto 411 +490 continue + call slmap (olng, olat, 0.0d0, 0.0d0, px, 0.0d0, 2000. + * 0d0, memd((((cooout+10)-1)/2+1)) , olng, olat) + goto 411 +410 continue + if (sw0006.lt.1.or.sw0006.gt.5) goto 411 + goto (420,420,450,470,490),sw0006 +411 continue + goto 391 +500 continue + call sleqga (olng, olat, olng, olat) + goto 391 +510 continue + call sleqga (olng, olat, olng, olat) + call slgasu (olng, olat, olng, olat) + goto 391 +520 continue + olng = ilng + olat = ilat + goto 391 +390 continue + if (sw0005.lt.1.or.sw0005.gt.4) goto 520 + goto (400,520,500,510),sw0005 +391 continue + goto 181 +530 continue + sw0007=(memi(cooout+12) ) + goto 540 +550 continue + call slgaeq (ilng, ilat, olng, olat) + sw0008=(memi(cooout+13) ) + goto 560 +570 continue + call slf54z (olng, olat, slepb(memd((((cooout+10)-1)/2 + * +1)) ), olng, olat, pmr, pmd) + call slsuet (olng, olat, 1950.0d0, olng, olat) + if (.not.(memd((((cooout+8)-1)/2+1)) .ne. 1950.0d0)) + * goto 580 + call slprcs (1, 1950.0d0, memd((((cooout+8)-1)/2+1) + * ) , olng, olat) +580 continue + if (.not.(memi(cooout+13) .eq. 1)) goto 590 + call sladet (olng, olat, memd((((cooout+8)-1)/2+1)) + * , olng, olat) +590 continue + goto 561 +600 continue + if (.not.(memd((((cooout+8)-1)/2+1)) .ne. 2000.0d0)) + * goto 610 + call slprcs (2, 2000.0d0, memd((((cooout+8)-1)/2+1) + * ) , olng, olat) +610 continue + goto 561 +620 continue + call slf5hz (olng, olat, 2000.0d0, olng, olat) + if (.not.(memd((((cooout+8)-1)/2+1)) .ne. 2000.0d0)) + * goto 630 + call slprcs (2, 2000.0d0, memd((((cooout+8)-1)/2+1) + * ) , olng, olat) +630 continue + goto 561 +640 continue + call slmap (olng, olat, 0.0d0, 0.0d0, px, 0.0d0, 2000. + * 0d0, memd((((cooout+10)-1)/2+1)) , olng, olat) + goto 561 +560 continue + if (sw0008.lt.1.or.sw0008.gt.5) goto 561 + goto (570,570,600,620,640),sw0008 +561 continue + goto 541 +650 continue + call slgaeq (ilng, ilat, olng, olat) + call sleqec (olng, olat, memd((((cooout+10)-1)/2+1)) , + * olng, olat) + goto 541 +660 continue + call slgasu (ilng, ilat, olng, olat) + goto 541 +670 continue + olng = ilng + olat = ilat + goto 541 +540 continue + if (sw0007.lt.1.or.sw0007.gt.4) goto 670 + goto (550,650,670,660),sw0007 +541 continue + goto 181 +680 continue + sw0009=(memi(cooout+12) ) + goto 690 +700 continue + call slsuga (ilng, ilat, olng, olat) + sw0010=(memi(cooout+13) ) + goto 710 +720 continue + call slgaeq (olng, olat, olng, olat) + call slf54z (olng, olat, slepb (memd((((cooout+10)-1)/ + * 2+1)) ), olng, olat, pmr, pmd) + call slsuet (olng, olat, 1950.0d0, olng, olat) + if (.not.(memd((((cooout+8)-1)/2+1)) .ne. 1950.0d0)) + * goto 730 + call slprcs (1, 1950.0d0, memd((((cooout+8)-1)/2+1) + * ) , olng, olat) +730 continue + call sladet (olng, olat, memd((((cooout+8)-1)/2+1)) , + * olng, olat) + goto 711 +740 continue + call slgaeq (olng, olat, olng, olat) + call slf54z (olng, olat, slepb (memd((((cooout+10)-1)/ + * 2+1)) ), olng, olat, pmr, pmd) + call slsuet (olng, olat, 1950.0d0, olng, olat) + if (.not.(memd((((cooout+8)-1)/2+1)) .ne. 1950.0d0)) + * goto 750 + call slprcs (1, 1950.0d0, memd((((cooout+8)-1)/2+1) + * ) , olng, olat) +750 continue + goto 711 +760 continue + call slgaeq (olng, olat, olng, olat) + if (.not.(memd((((cooout+8)-1)/2+1)) .ne. 2000.0d0)) + * goto 770 + call slprcs (2, 2000.0d0, memd((((cooout+8)-1)/2+1) + * ) , olng, olat) +770 continue + goto 711 +780 continue + call slgaeq (olng, olat, olng, olat) + call slf5hz (olng, olat, 2000.0d0, olng, olat) + if (.not.(memd((((cooout+8)-1)/2+1)) .ne. 2000.0d0)) + * goto 790 + call slprcs (2, 2000.0d0, memd((((cooout+8)-1)/2+1) + * ) , olng, olat) +790 continue + goto 711 +800 continue + call slgaeq (olng, olat, olng, olat) + call slmap (olng, olat, 0.0d0, 0.0d0, px, 0.0d0, 2000. + * 0d0, memd((((cooout+10)-1)/2+1)) , olng, olat) + goto 711 +710 continue + if (sw0010.lt.1.or.sw0010.gt.5) goto 711 + goto (720,740,760,780,800),sw0010 +711 continue + goto 691 +810 continue + call slsuga (ilng, ilat, olng, olat) + call slgaeq (olng, olat, olng, olat) + call sleqec (olng, olat, memd((((cooout+10)-1)/2+1)) , + * olng, olat) + goto 691 +820 continue + call slsuga (ilng, ilat, olng, olat) + goto 691 +830 continue + olng = ilng + olat = ilat + goto 691 +690 continue + if (sw0009.lt.1.or.sw0009.gt.3) goto 830 + goto (700,810,820),sw0009 +691 continue + goto 181 +840 continue + olng = ilng + olat = ilat + goto 181 +180 continue + if (sw0002.lt.1.or.sw0002.gt.4) goto 840 + goto (190,380,530,680),sw0002 +181 continue +100 return + end + subroutine skequl (cooin, cooout, ilng, ilat, ipmlng, ipmlat, px, + *rv, olng, olat) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer cooin + integer cooout + double precision ilng + double precision ilat + double precision ipmlng + double precision ipmlat + double precision px + double precision rv + double precision olng + double precision olat + integer pmflag + double precision pmr + double precision pmd + double precision slepb + double precision slepj + integer sw0001,sw0002,sw0003,sw0004 + save + if (.not.((memi(cooin+13) .eq. memi(cooout+13) ) .and. (memd((( + * (cooin+8)-1)/2+1)) .eq. memd((((cooout+8)-1)/2+1)) ) .and. ( + * memd((((cooin+10)-1)/2+1)) .eq. memd((((cooout+10)-1)/2+1)) ))) + * goto 110 + olng = ilng + olat = ilat + goto 100 +110 continue + if (.not.(.not. ((ipmlng).eq.1.6d308) .and. .not. ((ipmlat).eq. + * 1.6d308))) goto 120 + pmflag = 1 + goto 121 +120 continue + pmflag = 0 +121 continue + sw0001=(memi(cooin+13) ) + goto 130 +140 continue + if (.not.(pmflag .eq. 1)) goto 150 + call slpm (ilng, ilat, ipmlng, ipmlat, px, rv, slepb ( + * memd((((cooin+10)-1)/2+1)) ), slepb (memd((((cooout+10)-1 + * )/2+1)) ), olng, olat) + goto 151 +150 continue + olng = ilng + olat = ilat +151 continue + if (.not.(memi(cooin+13) .eq. 1)) goto 160 + call slsuet (olng, olat, memd((((cooin+8)-1)/2+1)) , olng + * , olat) +160 continue + if (.not.(memd((((cooin+8)-1)/2+1)) .ne. 1950.0d0)) goto 170 + call slprcs (1, memd((((cooin+8)-1)/2+1)) , 1950.0d0, + * olng, olat) +170 continue + call sladet (olng, olat, 1950.0d0, olng, olat) + if (.not.(pmflag .eq. 1)) goto 180 + call slf45z (olng, olat, slepb (memd((((cooout+10)-1)/2+1 + * )) ), olng, olat) + goto 181 +180 continue + call slf45z (olng, olat, slepb (memd((((cooin+10)-1)/2+1) + * ) ), olng, olat) +181 continue + sw0002=(memi(cooout+13) ) + goto 190 +200 continue + call slf54z (olng, olat, slepb (memd((((cooout+10)-1)/2+1 + * )) ), olng, olat, pmr, pmd) + call slsuet (olng, olat, 1950.0d0, olng, olat) + if (.not.(memd((((cooout+8)-1)/2+1)) .ne. 1950.0d0)) goto + * 210 + call slprcs (1, 1950.0d0, memd((((cooout+8)-1)/2+1)) , + * olng, olat) +210 continue + if (.not.(memi(cooout+13) .eq. 1)) goto 220 + call sladet (olng, olat, memd((((cooout+8)-1)/2+1)) , + * olng, olat) +220 continue + goto 191 +230 continue + if (.not.(memd((((cooout+8)-1)/2+1)) .ne. 2000.0d0)) goto + * 240 + call slprcs (2, 2000.0d0, memd((((cooout+8)-1)/2+1)) , + * olng, olat) +240 continue + goto 191 +250 continue + call slf5hz (olng, olat, 2000.0d0, olng, olat) + if (.not.(memd((((cooout+8)-1)/2+1)) .ne. 2000.0d0)) goto + * 260 + call slprcs (2, 2000.0d0, memd((((cooout+8)-1)/2+1)) , + * olng, olat) +260 continue + goto 191 +270 continue + call slmap (olng, olat, 0.0d0, 0.0d0, px, 0.0d0, 2000.0d0 + * , memd((((cooout+10)-1)/2+1)) , olng, olat) + goto 191 +190 continue + if (sw0002.lt.1.or.sw0002.gt.5) goto 191 + goto (200,200,230,250,270),sw0002 +191 continue + goto 131 +280 continue + if (.not.(memi(cooin+13) .eq. 3)) goto 290 + if (.not.(pmflag .eq. 1)) goto 300 + call slpm (ilng, ilat, ipmlng, ipmlat, px, rv, slepj ( + * memd((((cooin+10)-1)/2+1)) ), slepj (memd((((cooout+10 + * )-1)/2+1)) ), olng, olat) + goto 301 +300 continue + olng = ilng + olat = ilat +301 continue + goto 291 +290 continue + call slamp (ilng, ilat, memd((((cooin+10)-1)/2+1)) , 2000 + * .0d0, olng, olat) +291 continue + sw0003=(memi(cooout+13) ) + goto 310 +320 continue + if (.not.(memd((((cooin+8)-1)/2+1)) .ne. 2000.0d0)) goto + * 330 + call slprcs (2, memd((((cooin+8)-1)/2+1)) , 2000.0d0, + * olng, olat) +330 continue + call slf54z (olng, olat, slepb(memd((((cooout+10)-1)/2+1) + * ) ), olng, olat, pmr, pmd) + call slsuet (olng, olat, 1950.0d0, olng, olat) + if (.not.(memd((((cooout+8)-1)/2+1)) .ne. 1950.0d0)) goto + * 340 + call slprcs (1, 1950.0d0, memd((((cooout+8)-1)/2+1)) , + * olng, olat) +340 continue + if (.not.(memi(cooout+13) .eq. 1)) goto 350 + call sladet (olng, olat, memd((((cooout+8)-1)/2+1)) , + * olng, olat) +350 continue + goto 311 +360 continue + if (.not.(memd((((cooin+8)-1)/2+1)) .ne. memd((((cooout+8 + * )-1)/2+1)) )) goto 370 + call slprcs (2, memd((((cooin+8)-1)/2+1)) , memd(((( + * cooout+8)-1)/2+1)) , olng, olat) +370 continue + goto 311 +380 continue + if (.not.(memd((((cooin+8)-1)/2+1)) .ne. 2000.0d0)) goto + * 390 + call slprcs (2, memd((((cooin+8)-1)/2+1)) , 2000.0d0, + * olng, olat) +390 continue + call slf5hz (olng, olat, slepj(memd((((cooin+10)-1)/2+1)) + * ), olng, olat) + if (.not.(memd((((cooout+8)-1)/2+1)) .ne. 2000.0d0)) goto + * 400 + call slprcs (2, 2000.0d0, memd((((cooout+8)-1)/2+1)) , + * olng, olat) +400 continue + goto 311 +410 continue + if (.not.(memd((((cooin+8)-1)/2+1)) .ne. 2000.0d0)) goto + * 420 + call slprcs (2, memd((((cooin+8)-1)/2+1)) , 2000.0d0, + * olng, olat) +420 continue + call slmap (olng, olat, 0.0d0, 0.0d0, px, 0.0d0, 2000.0d0 + * , memd((((cooout+10)-1)/2+1)) , olng, olat) + goto 311 +310 continue + if (sw0003.lt.1.or.sw0003.gt.5) goto 311 + goto (320,320,360,380,410),sw0003 +311 continue + goto 131 +430 continue + if (.not.(pmflag .eq. 1)) goto 440 + call slpm (ilng, ilat, ipmlng, ipmlat, px, rv, slepj ( + * memd((((cooin+10)-1)/2+1)) ), slepj (memd((((cooout+10)-1 + * )/2+1)) ), olng, olat) + goto 441 +440 continue + olng = ilng + olat = ilat +441 continue + sw0004=(memi(cooout+13) ) + goto 450 +460 continue + if (.not.(memd((((cooin+8)-1)/2+1)) .ne. 2000.0d0)) goto + * 470 + call slprcs (2, memd((((cooin+8)-1)/2+1)) , 2000.0d0, + * olng, olat) +470 continue + call slhf5z (olng, olat, 2000.0d0, olng, olat, pmr, pmd) + call slf54z (olng, olat, slepb(memd((((cooout+10)-1)/2+1) + * ) ), olng, olat, pmr, pmd) + call slsuet (olng, olat, 1950.0d0, olng, olat) + if (.not.(memd((((cooout+8)-1)/2+1)) .ne. 1950.0d0)) goto + * 480 + call slprcs (1, 1950.0d0, memd((((cooout+8)-1)/2+1)) , + * olng, olat) +480 continue + if (.not.(memi(cooout+13) .eq. 1)) goto 490 + call sladet (olng, olat, memd((((cooout+8)-1)/2+1)) , + * olng, olat) +490 continue + goto 451 +500 continue + if (.not.(memd((((cooin+8)-1)/2+1)) .ne. 2000.0d0)) goto + * 510 + call slprcs (2, memd((((cooin+8)-1)/2+1)) , 2000.0d0, + * olng, olat) +510 continue + call slhf5z (olng, olat, slepj(memd((((cooout+10)-1)/2+1) + * ) ), olng, olat, pmr, pmd) + if (.not.(memd((((cooout+8)-1)/2+1)) .ne. 2000.0d0)) goto + * 520 + call slprcs (2, 2000.0d0, memd((((cooout+8)-1)/2+1)) , + * olng, olat) +520 continue + goto 451 +530 continue + if (.not.(memd((((cooin+8)-1)/2+1)) .ne. memd((((cooout+8 + * )-1)/2+1)) )) goto 540 + call slprcs (2, memd((((cooin+8)-1)/2+1)) , memd(((( + * cooout+8)-1)/2+1)) , olng, olat) +540 continue + goto 451 +550 continue + if (.not.(memd((((cooin+8)-1)/2+1)) .ne. 2000.0d0)) goto + * 560 + call slprcs (2, memd((((cooin+8)-1)/2+1)) , 2000.0d0, + * olng, olat) +560 continue + call slhf5z (olng, olat, slepj(memd((((cooout+10)-1)/2+1) + * ) ), olng, olat, pmr, pmd) + call slmap (olng, olat, 0.0d0, 0.0d0, px, 0.0d0, 2000.0d0 + * , memd((((cooout+10)-1)/2+1)) , olng, olat) + goto 451 +450 continue + if (sw0004.lt.1.or.sw0004.gt.5) goto 451 + goto (460,460,500,530,550),sw0004 +451 continue + goto 131 +130 continue + if (sw0001.lt.1.or.sw0001.gt.5) goto 131 + goto (140,140,280,430,280),sw0001 +131 continue +100 return + end +c sleceq sl_eceq +c sleqec sl_eqec +c sladet sl_adet +c sleqga sl_eqga +c slgaeq sl_gaeq +c slf45z sl_f45z +c slf54z sl_f54z +c slhf5z sl_hf5z +c slf5hz sl_f5hz +c slgasu sl_gasu +c slsuga sl_suga +c skequl sk_equatorial +c sklltn sk_lltran +c slprcs sl_prcs +c skultn sk_ultran +c slsuet sl_suet diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/sktransform.x b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/sktransform.x new file mode 100644 index 00000000..a8cf87c3 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/sktransform.x @@ -0,0 +1,577 @@ +include <math.h> +include "skywcsdef.h" +include "skywcs.h" + +# SK_ULTRAN -- Transform the sky coordinates from the input coordinate +# system to the output coordinate system using the units conversions as +# appropriate. + +procedure sk_ultran (cooin, cooout, ilng, ilat, olng, olat, npts) + +pointer cooin #I pointer to the input coordinate system structure +pointer cooout #I pointer to the output coordinate system structure +double ilng[ARB] #I the input ra/longitude in radians +double ilat[ARB] #I the input dec/latitude in radians +double olng[ARB] #O the output ra/longitude in radians +double olat[ARB] #O the output dec/latitude in radians +int npts #I the number of points to be converted + +double tilng, tilat, tolng, tolat +int i + +begin + do i = 1, npts { + + switch (SKY_NLNGUNITS(cooin)) { + case SKY_HOURS: + tilng = DEGTORAD(15.0d0 * ilng[i]) + case SKY_DEGREES: + tilng = DEGTORAD(ilng[i]) + case SKY_RADIANS: + tilng = ilng[i] + default: + tilng = ilng[i] + } + switch (SKY_NLATUNITS(cooin)) { + case SKY_HOURS: + tilat = DEGTORAD(15.0d0 * ilat[i]) + case SKY_DEGREES: + tilat = DEGTORAD(ilat[i]) + case SKY_RADIANS: + tilat = ilat[i] + default: + tilat = ilat[i] + } + + call sk_lltran (cooin, cooout, tilng, tilat, INDEFD, INDEFD, + 0.0d0, 0.0d0, tolng, tolat) + + switch (SKY_NLNGUNITS(cooout)) { + case SKY_HOURS: + olng[i] = RADTODEG(tolng) / 15.0d0 + case SKY_DEGREES: + olng[i] = RADTODEG(tolng) + case SKY_RADIANS: + olng[i] = tolng + default: + olng[i] = tolng + } + switch (SKY_NLATUNITS(cooout)) { + case SKY_HOURS: + olat[i] = RADTODEG(tolat) / 15.0d0 + case SKY_DEGREES: + olat[i] = RADTODEG(tolat) + case SKY_RADIANS: + olat[i] = tolat + default: + olat[i] = tolat + } + } +end + + +# SK_LLTRAN -- Transform the sky coordinate from the input coordinate +# system to the output coordinate system assuming that all the coordinate +# are in radians. + +procedure sk_lltran (cooin, cooout, ilng, ilat, ipmlng, ipmlat, px, rv, + olng, olat) + +pointer cooin #I pointer to the input coordinate system structure +pointer cooout #I pointer to the output coordinate system structure +double ilng #I the input ra/longitude in radians +double ilat #I the input dec/latitude in radians +double ipmlng #I the input proper motion in ra in radians +double ipmlat #I the input proper motion in dec in radians +double px #I the input parallax in arcseconds +double rv #I the input radial velocity in km / second +double olng #O the output ra/longitude in radians +double olat #O the output dec/latitude in radians + +int pmflag +double pmr, pmd +double sl_epj(), sl_epb() + +begin + # Test for the case where the input coordinate system is the + # same as the output coordinate system. + if (SKY_CTYPE(cooin) == SKY_CTYPE(cooout)) { + + switch (SKY_CTYPE(cooin)) { + + case CTYPE_EQUATORIAL: + call sk_equatorial (cooin, cooout, ilng, ilat, ipmlng, + ipmlat, px, rv, olng, olat) + + case CTYPE_ECLIPTIC: + if (SKY_EPOCH(cooin) == SKY_EPOCH(cooout)) { + olng = ilng + olat = ilat + } else { + call sl_eceq (ilng, ilat, SKY_EPOCH(cooin), olng, olat) + call sl_eqec (olng, olat, SKY_EPOCH(cooout), olng, olat) + } + + default: + olng = ilng + olat = ilat + } + + return + } + + # Compute proper motions ? + if (! IS_INDEFD(ipmlng) && ! IS_INDEFD(ipmlat)) + pmflag = YES + else + pmflag = NO + + # Cover the remaining cases. + switch (SKY_CTYPE(cooin)) { + + # The input system is equatorial. + case CTYPE_EQUATORIAL: + + switch (SKY_RADECSYS(cooin)) { + + case EQTYPE_FK4, EQTYPE_FK4NOE: + if (pmflag == YES) { + call sl_pm (ilng, ilat, ipmlng, ipmlat, px, rv, + sl_epb (SKY_EPOCH(cooin)), sl_epb (SKY_EPOCH(cooout)), + olng, olat) + } else { + olng = ilng + olat = ilat + } + if (SKY_RADECSYS(cooin) == EQTYPE_FK4) + call sl_suet (olng, olat, SKY_EQUINOX(cooin), olng, olat) + if (SKY_EQUINOX(cooin) != 1950.0d0) + call sl_prcs (1, SKY_EQUINOX(cooin), 1950.0d0, olng, olat) + call sl_adet (olng, olat, 1950.0d0, olng, olat) + if (pmflag == YES) + call sl_f45z (olng, olat, sl_epb(SKY_EPOCH(cooout)), + olng, olat) + else + call sl_f45z (olng, olat, sl_epb (SKY_EPOCH(cooin)), + olng, olat) + + case EQTYPE_FK5: + if (pmflag == YES) { + call sl_pm (ilng, ilat, ipmlng, ipmlat, px, rv, + sl_epj (SKY_EPOCH(cooin)), sl_epj(SKY_EPOCH(cooout)), + olng, olat) + } else { + olng = ilng + olat = ilat + } + if (SKY_EQUINOX(cooin) != 2000.0d0) + call sl_prcs (2, SKY_EQUINOX(cooin), 2000.0d0, olng, olat) + + case EQTYPE_ICRS: + if (pmflag == YES) { + call sl_pm (ilng, ilat, ipmlng, ipmlat, px, rv, + sl_epj (SKY_EPOCH(cooin)), sl_epj(SKY_EPOCH(cooout)), + olng, olat) + } else { + olng = ilng + olat = ilat + } + if (SKY_EQUINOX(cooin) != 2000.0d0) + call sl_prcs (2, SKY_EQUINOX(cooin), 2000.0d0, olng, olat) + call sl_hf5z (olng, olat, 2000.0d0, olng, olat, pmr, pmd) + + case EQTYPE_GAPPT: + call sl_amp (ilng, ilat, SKY_EPOCH(cooin), 2000.0d0, olng, olat) + + } + + switch (SKY_CTYPE(cooout)) { + + # The output coordinate system is ecliptic. + case CTYPE_ECLIPTIC: + call sl_eqec (olng, olat, SKY_EPOCH(cooout), olng, olat) + + # The output coordinate system is galactic. + case CTYPE_GALACTIC: + call sl_eqga (olng, olat, olng, olat) + + # The output coordinate system is supergalactic. + case CTYPE_SUPERGALACTIC: + call sl_eqga (olng, olat, olng, olat) + call sl_gasu (olng, olat, olng, olat) + + default: + olng = ilng + olat = ilat + } + + # The input coordinate system is ecliptic. + case CTYPE_ECLIPTIC: + + call sl_eceq (ilng, ilat, SKY_EPOCH(cooin), olng, olat) + switch (SKY_CTYPE(cooout)) { + + # The output coordinate system is equatorial. + case CTYPE_EQUATORIAL: + + switch (SKY_RADECSYS(cooout)) { + case EQTYPE_FK4, EQTYPE_FK4NOE: + call sl_f54z (olng, olat, sl_epb(SKY_EPOCH(cooout)), + olng, olat, pmr, pmd) + call sl_suet (olng, olat, 1950.0d0, olng, olat) + if (SKY_EQUINOX(cooout) != 1950.0d0) + call sl_prcs (1, 1950.0d0, SKY_EQUINOX(cooout), + olng, olat) + if (SKY_RADECSYS(cooout) == EQTYPE_FK4) + call sl_adet (olng, olat, SKY_EQUINOX(cooout), + olng, olat) + + case EQTYPE_FK5: + if (SKY_EQUINOX(cooout) != 2000.0d0) + call sl_prcs (2, 2000.0d0, SKY_EQUINOX(cooout), + olng, olat) + + case EQTYPE_ICRS: + #call sl_f5hz (olng, olat, sl_epj(SKY_EPOCH(cooin)), + #olng, olat) + call sl_f5hz (olng, olat, 2000.0d0, olng, olat) + if (SKY_EQUINOX(cooout) != 2000.0d0) + call sl_prcs (2, 2000.0d0, SKY_EQUINOX(cooout), + olng, olat) + + case EQTYPE_GAPPT: + call sl_map (olng, olat, 0.0d0, 0.0d0, px, 0.0d0, + 2000.0d0, SKY_EPOCH(cooout), olng, olat) + } + + # The output coordinate system is galactic. + case CTYPE_GALACTIC: + call sl_eqga (olng, olat, olng, olat) + + # The output system is supergalactic. + case CTYPE_SUPERGALACTIC: + call sl_eqga (olng, olat, olng, olat) + call sl_gasu (olng, olat, olng, olat) + + default: + olng = ilng + olat = ilat + } + + # The input coordinate system is galactic. + case CTYPE_GALACTIC: + + switch (SKY_CTYPE(cooout)) { + + # The output coordinate system is equatorial. + case CTYPE_EQUATORIAL: + call sl_gaeq (ilng, ilat, olng, olat) + + switch (SKY_RADECSYS(cooout)) { + case EQTYPE_FK4, EQTYPE_FK4NOE: + call sl_f54z (olng, olat, sl_epb(SKY_EPOCH(cooout)), + olng, olat, pmr, pmd) + call sl_suet (olng, olat, 1950.0d0, olng, olat) + if (SKY_EQUINOX(cooout) != 1950.0d0) + call sl_prcs (1, 1950.0d0, SKY_EQUINOX(cooout), + olng, olat) + if (SKY_RADECSYS(cooout) == EQTYPE_FK4) + call sl_adet (olng, olat, SKY_EQUINOX(cooout), + olng, olat) + + case EQTYPE_FK5: + if (SKY_EQUINOX(cooout) != 2000.0d0) + call sl_prcs (2, 2000.0d0, SKY_EQUINOX(cooout), + olng, olat) + + case EQTYPE_ICRS: + call sl_f5hz (olng, olat, 2000.0d0, olng, olat) + if (SKY_EQUINOX(cooout) != 2000.0d0) + call sl_prcs (2, 2000.0d0, SKY_EQUINOX(cooout), + olng, olat) + + case EQTYPE_GAPPT: + call sl_map (olng, olat, 0.0d0, 0.0d0, px, 0.0d0, + 2000.0d0, SKY_EPOCH(cooout), olng, olat) + } + + # The output coordinate system is ecliptic. + case CTYPE_ECLIPTIC: + call sl_gaeq (ilng, ilat, olng, olat) + call sl_eqec (olng, olat, SKY_EPOCH(cooout), olng, olat) + + # The output coordinate system is supergalactic. + case CTYPE_SUPERGALACTIC: + call sl_gasu (ilng, ilat, olng, olat) + + default: + olng = ilng + olat = ilat + } + + # The input coordinates are supergalactic. + case CTYPE_SUPERGALACTIC: + + switch (SKY_CTYPE(cooout)) { + + case CTYPE_EQUATORIAL: + call sl_suga (ilng, ilat, olng, olat) + + switch (SKY_RADECSYS(cooout)) { + + case EQTYPE_FK4: + call sl_gaeq (olng, olat, olng, olat) + call sl_f54z (olng, olat, sl_epb (SKY_EPOCH(cooout)), + olng, olat, pmr, pmd) + call sl_suet (olng, olat, 1950.0d0, olng, olat) + if (SKY_EQUINOX(cooout) != 1950.0d0) + call sl_prcs (1, 1950.0d0, SKY_EQUINOX(cooout), + olng, olat) + call sl_adet (olng, olat, SKY_EQUINOX(cooout), olng, olat) + + case EQTYPE_FK4NOE: + call sl_gaeq (olng, olat, olng, olat) + call sl_f54z (olng, olat, sl_epb (SKY_EPOCH(cooout)), + olng, olat, pmr, pmd) + call sl_suet (olng, olat, 1950.0d0, olng, olat) + if (SKY_EQUINOX(cooout) != 1950.0d0) + call sl_prcs (1, 1950.0d0, SKY_EQUINOX(cooout), + olng, olat) + + case EQTYPE_FK5: + call sl_gaeq (olng, olat, olng, olat) + if (SKY_EQUINOX(cooout) != 2000.0d0) + call sl_prcs (2, 2000.0d0, SKY_EQUINOX(cooout), + olng, olat) + + case EQTYPE_ICRS: + call sl_gaeq (olng, olat, olng, olat) + call sl_f5hz (olng, olat, 2000.0d0, olng, olat) + if (SKY_EQUINOX(cooout) != 2000.0d0) + call sl_prcs (2, 2000.0d0, SKY_EQUINOX(cooout), + olng, olat) + + case EQTYPE_GAPPT: + call sl_gaeq (olng, olat, olng, olat) + call sl_map (olng, olat, 0.0d0, 0.0d0, px, 0.0d0, + 2000.0d0, SKY_EPOCH(cooout), olng, olat) + } + + case CTYPE_ECLIPTIC: + call sl_suga (ilng, ilat, olng, olat) + call sl_gaeq (olng, olat, olng, olat) + call sl_eqec (olng, olat, SKY_EPOCH(cooout), olng, olat) + + case CTYPE_GALACTIC: + call sl_suga (ilng, ilat, olng, olat) + + default: + olng = ilng + olat = ilat + } + + default: + olng = ilng + olat = ilat + } +end + + +# SK_EQUATORIAL -- Convert / precess equatorial coordinates. + +procedure sk_equatorial (cooin, cooout, ilng, ilat, ipmlng, ipmlat, + px, rv, olng, olat) + +pointer cooin #I the input coordinate system structure +pointer cooout #I the output coordinate system structure +double ilng #I the input ra in radians +double ilat #I the input dec in radians +double ipmlng #I the input proper motion in ra in radians +double ipmlat #I the input proper motion in dec in radians +double px #I the input parallax in arcseconds +double rv #I the input radial valocity in km / second +double olng #O the output ra in radians +double olat #O the output dec in radians + +int pmflag +double pmr, pmd +double sl_epb(), sl_epj() + +begin + # Check to see whether or not conversion / precession is necessary. + if ((SKY_RADECSYS(cooin) == SKY_RADECSYS(cooout)) && + (SKY_EQUINOX(cooin) == SKY_EQUINOX(cooout)) && + (SKY_EPOCH(cooin) == SKY_EPOCH(cooout))) { + olng = ilng + olat = ilat + return + } + + # Compute proper motions ? + if (! IS_INDEFD(ipmlng) && ! IS_INDEFD(ipmlat)) + pmflag = YES + else + pmflag = NO + + switch (SKY_RADECSYS(cooin)) { + + # The input coordinate system is FK4 with or without the E terms. + case EQTYPE_FK4, EQTYPE_FK4NOE: + + if (pmflag == YES) { + call sl_pm (ilng, ilat, ipmlng, ipmlat, px, rv, + sl_epb (SKY_EPOCH(cooin)), sl_epb (SKY_EPOCH(cooout)), + olng, olat) + } else { + olng = ilng + olat = ilat + } + if (SKY_RADECSYS(cooin) == EQTYPE_FK4) + call sl_suet (olng, olat, SKY_EQUINOX(cooin), olng, olat) + if (SKY_EQUINOX(cooin) != 1950.0d0) + call sl_prcs (1, SKY_EQUINOX(cooin), 1950.0d0, olng, olat) + call sl_adet (olng, olat, 1950.0d0, olng, olat) + if (pmflag == YES) + call sl_f45z (olng, olat, sl_epb (SKY_EPOCH(cooout)), + olng, olat) + else + call sl_f45z (olng, olat, sl_epb (SKY_EPOCH(cooin)), + olng, olat) + + switch (SKY_RADECSYS(cooout)) { + + # The output coordinate system is FK4 with and without the E terms. + case EQTYPE_FK4, EQTYPE_FK4NOE: + call sl_f54z (olng, olat, sl_epb (SKY_EPOCH(cooout)), + olng, olat, pmr, pmd) + call sl_suet (olng, olat, 1950.0d0, olng, olat) + if (SKY_EQUINOX(cooout) != 1950.0d0) + call sl_prcs (1, 1950.0d0, SKY_EQUINOX(cooout), + olng, olat) + if (SKY_RADECSYS(cooout) == EQTYPE_FK4) + call sl_adet (olng, olat, SKY_EQUINOX(cooout), olng, olat) + + # The output coordinate system is FK5. + case EQTYPE_FK5: + if (SKY_EQUINOX(cooout) != 2000.0d0) + call sl_prcs (2, 2000.0d0, SKY_EQUINOX(cooout), olng, olat) + + # The output coordinate system is ICRS (Hipparcos). + case EQTYPE_ICRS: + call sl_f5hz (olng, olat, 2000.0d0, olng, olat) + if (SKY_EQUINOX(cooout) != 2000.0d0) + call sl_prcs (2, 2000.0d0, SKY_EQUINOX(cooout), olng, olat) + + # The output coordinate system is geocentric apparent. + case EQTYPE_GAPPT: + call sl_map (olng, olat, 0.0d0, 0.0d0, px, 0.0d0, 2000.0d0, + SKY_EPOCH(cooout), olng, olat) + } + + # The input coordinate system is FK5 or geocentric apparent. + case EQTYPE_FK5, EQTYPE_GAPPT: + + if (SKY_RADECSYS(cooin) == EQTYPE_FK5) { + if (pmflag == YES) { + call sl_pm (ilng, ilat, ipmlng, ipmlat, px, rv, + sl_epj (SKY_EPOCH(cooin)), sl_epj (SKY_EPOCH(cooout)), + olng, olat) + } else { + olng = ilng + olat = ilat + } + } else + call sl_amp (ilng, ilat, SKY_EPOCH(cooin), 2000.0d0, olng, olat) + + switch (SKY_RADECSYS(cooout)) { + + # The output coordinate system is FK4 with or without the E terms. + case EQTYPE_FK4, EQTYPE_FK4NOE: + if (SKY_EQUINOX(cooin) != 2000.0d0) + call sl_prcs (2, SKY_EQUINOX(cooin), 2000.0d0, olng, olat) + call sl_f54z (olng, olat, sl_epb(SKY_EPOCH(cooout)), + olng, olat, pmr, pmd) + call sl_suet (olng, olat, 1950.0d0, olng, olat) + if (SKY_EQUINOX(cooout) != 1950.0d0) + call sl_prcs (1, 1950.0d0, SKY_EQUINOX(cooout), olng, olat) + if (SKY_RADECSYS(cooout) == EQTYPE_FK4) + call sl_adet (olng, olat, SKY_EQUINOX(cooout), olng, olat) + + # The output coordinate system is FK5. + case EQTYPE_FK5: + if (SKY_EQUINOX(cooin) != SKY_EQUINOX(cooout)) + call sl_prcs (2, SKY_EQUINOX(cooin), SKY_EQUINOX(cooout), + olng, olat) + + # The output coordinate system is ICRS. + case EQTYPE_ICRS: + if (SKY_EQUINOX(cooin) != 2000.0d0) + call sl_prcs (2, SKY_EQUINOX(cooin), 2000.0d0, olng, olat) + call sl_f5hz (olng, olat, sl_epj(SKY_EPOCH(cooin)), olng, olat) + if (SKY_EQUINOX(cooout) != 2000.0d0) + call sl_prcs (2, 2000.0d0, SKY_EQUINOX(cooout), olng, olat) + + # The output coordinate system is geocentric apparent. + case EQTYPE_GAPPT: + if (SKY_EQUINOX(cooin) != 2000.0d0) + call sl_prcs (2, SKY_EQUINOX(cooin), 2000.0d0, olng, olat) + call sl_map (olng, olat, 0.0d0, 0.0d0, px, 0.0d0, 2000.0d0, + SKY_EPOCH(cooout), olng, olat) + } + + # The input coordinate system is ICRS. + case EQTYPE_ICRS: + + if (pmflag == YES) { + call sl_pm (ilng, ilat, ipmlng, ipmlat, px, rv, + sl_epj (SKY_EPOCH(cooin)), sl_epj (SKY_EPOCH(cooout)), + olng, olat) + } else { + olng = ilng + olat = ilat + } + + switch (SKY_RADECSYS(cooout)) { + + # The output coordinate system is FK4 with or without the E terms. + case EQTYPE_FK4, EQTYPE_FK4NOE: + if (SKY_EQUINOX(cooin) != 2000.0d0) + call sl_prcs (2, SKY_EQUINOX(cooin), 2000.0d0, olng, olat) + call sl_hf5z (olng, olat, 2000.0d0, olng, olat, + pmr, pmd) + call sl_f54z (olng, olat, sl_epb(SKY_EPOCH(cooout)), olng, olat, + pmr, pmd) + call sl_suet (olng, olat, 1950.0d0, olng, olat) + if (SKY_EQUINOX(cooout) != 1950.0d0) + call sl_prcs (1, 1950.0d0, SKY_EQUINOX(cooout), olng, olat) + if (SKY_RADECSYS(cooout) == EQTYPE_FK4) + call sl_adet (olng, olat, SKY_EQUINOX(cooout), olng, olat) + + # The output coordinate system is FK5. + case EQTYPE_FK5: + if (SKY_EQUINOX(cooin) != 2000.0d0) + call sl_prcs (2, SKY_EQUINOX(cooin), 2000.0d0, olng, olat) + call sl_hf5z (olng, olat, sl_epj(SKY_EPOCH(cooout)), + olng, olat, pmr, pmd) + if (SKY_EQUINOX(cooout) != 2000.0d0) + call sl_prcs (2, 2000.0d0, SKY_EQUINOX(cooout), olng, olat) + + # The output coordinate system is ICRS. + case EQTYPE_ICRS: + if (SKY_EQUINOX(cooin) != SKY_EQUINOX(cooout)) + call sl_prcs (2, SKY_EQUINOX(cooin), SKY_EQUINOX(cooout), + olng, olat) + + # The output coordinate system is geocentric apparent. + case EQTYPE_GAPPT: + if (SKY_EQUINOX(cooin) != 2000.0d0) + call sl_prcs (2, SKY_EQUINOX(cooin), 2000.0d0, olng, olat) + call sl_hf5z (olng, olat, sl_epj(SKY_EPOCH(cooout)), + olng, olat, pmr, pmd) + call sl_map (olng, olat, 0.0d0, 0.0d0, px, 0.0d0, 2000.0d0, + SKY_EPOCH(cooout), olng, olat) + + } + + } +end diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skwrdstr.f b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skwrdstr.f new file mode 100644 index 00000000..41fd369e --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skwrdstr.f @@ -0,0 +1,45 @@ + integer function skwrdr (index, outstr, maxch, dict) + integer index + integer maxch + integer*2 outstr(*) + integer*2 dict(*) + integer i + integer len + integer start + integer count + integer xstrln + save + outstr(1) = 0 + if (.not.(dict(1) .eq. 0)) goto 110 + skwrdr = (0) + goto 100 +110 continue + count = 1 + len = xstrln(dict) + start = 2 +120 if (.not.(count .lt. index)) goto 122 + if (.not.(dict(start) .eq. dict(1))) goto 130 + count = count + 1 +130 continue + if (.not.(start .eq. len)) goto 140 + skwrdr = (0) + goto 100 +140 continue +121 start = start + 1 + goto 120 +122 continue + i = start +150 if (.not.(dict(i) .ne. 0 .and. dict(i) .ne. dict(1))) goto 152 + if (.not.(i - start + 1 .gt. maxch)) goto 160 + goto 152 +160 continue + outstr(i - start + 1) = dict(i) +151 i = i + 1 + goto 150 +152 continue + outstr(i - start + 1) = 0 + skwrdr = (count) + goto 100 +100 return + end +c skwrdr sk_wrdstr diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skwrdstr.x b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skwrdstr.x new file mode 100644 index 00000000..a7c6b359 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skwrdstr.x @@ -0,0 +1,53 @@ + +# SK_WRDSTR -- Search a dictionary string for a given string index number. +# This is the opposite function of strdic(), that returns the index for +# given string. The entries in the dictionary string are separated by +# a delimiter character which is the first character of the dictionary +# string. The index of the string found is returned as the function value. +# Otherwise, if there is no string for that index, a zero is returned. + +int procedure sk_wrdstr (index, outstr, maxch, dict) + +int index #I the string index +char outstr[ARB] #O the output string as found in dictionary +int maxch #I the maximum length of output string +char dict[ARB] #I the dictionary string + +int i, len, start, count + +int strlen() + +begin + # Clear output string + outstr[1] = EOS + + # Return if the dictionary is not long enough + if (dict[1] == EOS) + return (0) + + # Initialize counters + count = 1 + len = strlen (dict) + + # Search the dictionary string. This loop only terminates + # successfully if the index is found. Otherwise the procedure + # returns with and error condition. + for (start = 2; count < index; start = start + 1) { + if (dict[start] == dict[1]) + count = count + 1 + if (start == len) + return (0) + } + + # Extract the output string from the dictionary + for (i = start; dict[i] != EOS && dict[i] != dict[1]; i = i + 1) { + if (i - start + 1 > maxch) + break + outstr[i - start + 1] = dict[i] + } + + outstr[i - start + 1] = EOS + + # Return index for output string + return (count) +end diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skwrite.f b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skwrite.f new file mode 100644 index 00000000..223f8f1e --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skwrite.f @@ -0,0 +1,1014 @@ + subroutine skiipt (label, images, mw, coo) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer mw + integer coo + integer*2 label(*) + integer*2 images(*) + save + if (.not.(mw .eq. 0)) goto 110 + call skinpt (label, images, memi(coo+12) , memi(coo+13) , + * memd((((coo+8)-1)/2+1)) , memd((((coo+10)-1)/2+1)) ) + goto 111 +110 continue + call skimpt (label, images, memi(coo+12) , memi(coo+15) , + * memi(coo+16) , memi(coo+14) , memi(coo+19) , memi(coo+13) , + * memd((((coo+8)-1)/2+1)) , memd((((coo+10)-1)/2+1)) ) +111 continue +100 return + end + subroutine skiiwe (fd, label, images, mw, coo) + integer fd + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer mw + integer coo + integer*2 label(*) + integer*2 images(*) + save + if (.not.(mw .eq. 0)) goto 110 + call skinwe (fd, label, images, memi(coo+12) , memi(coo+13) + * , memd((((coo+8)-1)/2+1)) , memd((((coo+10)-1)/2+1)) ) + goto 111 +110 continue + call skimwe (fd, label, images, memi(coo+12) , memi(coo+15) + * , memi(coo+16) , memi(coo+14) , memi(coo+19) , memi(coo+13) + * , memd((((coo+8)-1)/2+1)) , memd((((coo+10)-1)/2+1)) ) +111 continue +100 return + end + subroutine skinpt (label, system, ctype, radecs, equinx, epoch) + integer ctype + integer radecs + double precision equinx + double precision epoch + integer*2 label(*) + integer*2 system(*) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer sp + integer radecr + double precision slepj + double precision slepb + integer skwrdr + integer sw0001,sw0002 + integer*2 st0001(30) + integer*2 st0002(4) + integer*2 st0003(36) + integer*2 st0004(37) + integer*2 st0005(46) + integer*2 st0006(46) + integer*2 st0007(31) + integer*2 st0008(37) + integer*2 st0009(31) + integer*2 st0010(37) + integer*2 st0011(36) + integer*2 st0012(37) + save + integer iyy + data (st0001(iyy),iyy= 1, 8) /124,102,107, 52,124,102,107, 52/ + data (st0001(iyy),iyy= 9,16) / 45,110,111, 45,101,124,102,107/ + data (st0001(iyy),iyy=17,24) / 53,124,105, 99,114,115,124,103/ + data (st0001(iyy),iyy=25,30) / 97,112,112,116,124, 0/ + data st0002 / 70, 75, 53, 0/ + data (st0003(iyy),iyy= 1, 8) / 37,115, 58, 32, 37,115, 32, 32/ + data (st0003(iyy),iyy= 9,16) / 67,111,111,114,100,105,110, 97/ + data (st0003(iyy),iyy=17,24) /116,101,115, 58, 32,101,113,117/ + data (st0003(iyy),iyy=25,32) / 97,116,111,114,105, 97,108, 32/ + data (st0003(iyy),iyy=33,36) / 37,115, 10, 0/ + data (st0004(iyy),iyy= 1, 8) / 32, 32, 32, 32, 77, 74, 68, 58/ + data (st0004(iyy),iyy= 9,16) / 32, 37, 48, 46, 53,102, 32, 69/ + data (st0004(iyy),iyy=17,24) /112,111, 99,104, 58, 32, 74, 37/ + data (st0004(iyy),iyy=25,32) / 48, 46, 56,102, 32, 66, 37, 48/ + data (st0004(iyy),iyy=33,37) / 46, 56,102, 10, 0/ + data (st0005(iyy),iyy= 1, 8) / 32, 32, 32, 32, 69,113,117,105/ + data (st0005(iyy),iyy= 9,16) /110,111,120, 58, 32, 74, 37, 48/ + data (st0005(iyy),iyy=17,24) / 46, 51,102, 32, 69,112,111, 99/ + data (st0005(iyy),iyy=25,32) /104, 58, 32, 74, 37, 48, 46, 56/ + data (st0005(iyy),iyy=33,40) /102, 32, 77, 74, 68, 58, 32, 37/ + data (st0005(iyy),iyy=41,46) / 48, 46, 53,102, 10, 0/ + data (st0006(iyy),iyy= 1, 8) / 32, 32, 32, 32, 69,113,117,105/ + data (st0006(iyy),iyy= 9,16) /110,111,120, 58, 32, 66, 37, 48/ + data (st0006(iyy),iyy=17,24) / 46, 51,102, 32, 69,112,111, 99/ + data (st0006(iyy),iyy=25,32) /104, 58, 32, 66, 37, 48, 46, 56/ + data (st0006(iyy),iyy=33,40) /102, 32, 77, 74, 68, 58, 32, 37/ + data (st0006(iyy),iyy=41,46) / 48, 46, 53,102, 10, 0/ + data (st0007(iyy),iyy= 1, 8) / 37,115, 58, 32, 37,115, 32, 32/ + data (st0007(iyy),iyy= 9,16) / 67,111,111,114,100,105,110, 97/ + data (st0007(iyy),iyy=17,24) /116,101,115, 58, 32,101, 99,108/ + data (st0007(iyy),iyy=25,31) /105,112,116,105, 99, 10, 0/ + data (st0008(iyy),iyy= 1, 8) / 32, 32, 32, 32, 77, 74, 68, 58/ + data (st0008(iyy),iyy= 9,16) / 32, 37, 48, 46, 53,102, 32, 69/ + data (st0008(iyy),iyy=17,24) /112,111, 99,104, 58, 32, 74, 37/ + data (st0008(iyy),iyy=25,32) / 48, 46, 56,102, 32, 66, 37, 48/ + data (st0008(iyy),iyy=33,37) / 46, 56,102, 10, 0/ + data (st0009(iyy),iyy= 1, 8) / 37,115, 58, 32, 37,115, 32, 32/ + data (st0009(iyy),iyy= 9,16) / 67,111,111,114,100,105,110, 97/ + data (st0009(iyy),iyy=17,24) /116,101,115, 58, 32,103, 97,108/ + data (st0009(iyy),iyy=25,31) / 97, 99,116,105, 99, 10, 0/ + data (st0010(iyy),iyy= 1, 8) / 32, 32, 32, 32, 77, 74, 68, 58/ + data (st0010(iyy),iyy= 9,16) / 32, 37, 48, 46, 53,102, 32, 69/ + data (st0010(iyy),iyy=17,24) /112,111, 99,104, 58, 32, 74, 37/ + data (st0010(iyy),iyy=25,32) / 48, 46, 56,102, 32, 66, 37, 48/ + data (st0010(iyy),iyy=33,37) / 46, 56,102, 10, 0/ + data (st0011(iyy),iyy= 1, 8) / 37,115, 58, 32, 37,115, 32, 32/ + data (st0011(iyy),iyy= 9,16) / 67,111,111,114,100,105,110, 97/ + data (st0011(iyy),iyy=17,24) /116,101,115, 58, 32,115,117,112/ + data (st0011(iyy),iyy=25,32) /101,114,103, 97,108, 97, 99,116/ + data (st0011(iyy),iyy=33,36) /105, 99, 10, 0/ + data (st0012(iyy),iyy= 1, 8) / 32, 32, 32, 32, 77, 74, 68, 58/ + data (st0012(iyy),iyy= 9,16) / 32, 37, 48, 46, 53,102, 32, 69/ + data (st0012(iyy),iyy=17,24) /112,111, 99,104, 58, 32, 74, 37/ + data (st0012(iyy),iyy=25,32) / 48, 46, 56,102, 32, 66, 37, 48/ + data (st0012(iyy),iyy=33,37) / 46, 56,102, 10, 0/ + call smark (sp) + call salloc (radecr, 255 , 2) + sw0001=(ctype) + goto 110 +120 continue + if (.not.(skwrdr (radecs, memc(radecr), 255 , st0001) .le. 0 + * )) goto 130 + call xstrcy(st0002, memc(radecr), 255 ) +130 continue + call strupr (memc(radecr)) + call xprinf(st0003) + call pargsr (label) + call pargsr (system) + call pargsr (memc(radecr)) + sw0002=(radecs) + goto 140 +150 continue + call xprinf(st0004) + call pargd (epoch) + if (.not.(((epoch).eq.1.6d308))) goto 160 + call pargd (1.6d308) + call pargd (1.6d308) + goto 161 +160 continue + call pargd (slepj (epoch)) + call pargd (slepb (epoch)) +161 continue + goto 141 +170 continue + call xprinf(st0005) + call pargd (equinx) + call pargd (slepj(epoch)) + call pargd (epoch) + goto 141 +180 continue + call xprinf(st0006) + call pargd (equinx) + call pargd (slepb(epoch)) + call pargd (epoch) + goto 141 +140 continue + sw0002=sw0002-2 + if (sw0002.lt.1.or.sw0002.gt.3) goto 180 + goto (170,170,150),sw0002 +141 continue + goto 111 +190 continue + call xprinf(st0007) + call pargsr (label) + call pargsr (system) + call xprinf(st0008) + call pargd (epoch) + if (.not.(((epoch).eq.1.6d308))) goto 200 + call pargd (1.6d308) + call pargd (1.6d308) + goto 201 +200 continue + call pargd (slepj(epoch)) + call pargd (slepb(epoch)) +201 continue + goto 111 +210 continue + call xprinf(st0009) + call pargsr (label) + call pargsr (system) + call xprinf(st0010) + call pargd (epoch) + call pargd (slepj (epoch)) + call pargd (slepb (epoch)) + goto 111 +220 continue + call xprinf(st0011) + call pargsr (label) + call pargsr (system) + call xprinf(st0012) + call pargd (epoch) + call pargd (slepj (epoch)) + call pargd (slepb (epoch)) + goto 111 +110 continue + if (sw0001.lt.1.or.sw0001.gt.4) goto 111 + goto (120,190,210,220),sw0001 +111 continue + call sfree (sp) +100 return + end + subroutine skinwe (fd, label, system, ctype, radecs, equinx, epoch + *) + integer fd + integer ctype + integer radecs + double precision equinx + double precision epoch + integer*2 label(*) + integer*2 system(*) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer sp + integer radecr + double precision slepj + double precision slepb + integer skwrdr + integer sw0001,sw0002 + integer*2 st0001(30) + integer*2 st0002(4) + integer*2 st0003(38) + integer*2 st0004(39) + integer*2 st0005(48) + integer*2 st0006(48) + integer*2 st0007(33) + integer*2 st0008(39) + integer*2 st0009(33) + integer*2 st0010(39) + integer*2 st0011(38) + integer*2 st0012(39) + save + integer iyy + data (st0001(iyy),iyy= 1, 8) /124,102,107, 52,124,102,107, 52/ + data (st0001(iyy),iyy= 9,16) / 45,110,111, 45,101,124,102,107/ + data (st0001(iyy),iyy=17,24) / 53,124,105, 99,114,115,124,103/ + data (st0001(iyy),iyy=25,30) / 97,112,112,116,124, 0/ + data st0002 / 70, 75, 53, 0/ + data (st0003(iyy),iyy= 1, 8) / 35, 32, 37,115, 58, 32, 37,115/ + data (st0003(iyy),iyy= 9,16) / 32, 32, 67,111,111,114,100,105/ + data (st0003(iyy),iyy=17,24) /110, 97,116,101,115, 58, 32,101/ + data (st0003(iyy),iyy=25,32) /113,117, 97,116,111,114,105, 97/ + data (st0003(iyy),iyy=33,38) /108, 32, 37,115, 10, 0/ + data (st0004(iyy),iyy= 1, 8) / 35, 32, 32, 32, 32, 32, 77, 74/ + data (st0004(iyy),iyy= 9,16) / 68, 58, 32, 37, 48, 46, 53,102/ + data (st0004(iyy),iyy=17,24) / 32, 69,112,111, 99,104, 58, 32/ + data (st0004(iyy),iyy=25,32) / 74, 37, 48, 46, 56,102, 32, 66/ + data (st0004(iyy),iyy=33,39) / 37, 48, 46, 56,102, 10, 0/ + data (st0005(iyy),iyy= 1, 8) / 35, 32, 32, 32, 32, 32, 69,113/ + data (st0005(iyy),iyy= 9,16) /117,105,110,111,120, 58, 32, 74/ + data (st0005(iyy),iyy=17,24) / 37, 48, 46, 51,102, 32, 69,112/ + data (st0005(iyy),iyy=25,32) /111, 99,104, 58, 32, 74, 37, 48/ + data (st0005(iyy),iyy=33,40) / 46, 56,102, 32, 77, 74, 68, 58/ + data (st0005(iyy),iyy=41,48) / 32, 37, 48, 46, 53,102, 10, 0/ + data (st0006(iyy),iyy= 1, 8) / 35, 32, 32, 32, 32, 32, 69,113/ + data (st0006(iyy),iyy= 9,16) /117,105,110,111,120, 58, 32, 66/ + data (st0006(iyy),iyy=17,24) / 37, 48, 46, 51,102, 32, 69,112/ + data (st0006(iyy),iyy=25,32) /111, 99,104, 58, 32, 66, 37, 48/ + data (st0006(iyy),iyy=33,40) / 46, 56,102, 32, 77, 74, 68, 58/ + data (st0006(iyy),iyy=41,48) / 32, 37, 48, 46, 53,102, 10, 0/ + data (st0007(iyy),iyy= 1, 8) / 35, 32, 37,115, 58, 32, 37,115/ + data (st0007(iyy),iyy= 9,16) / 32, 32, 67,111,111,114,100,105/ + data (st0007(iyy),iyy=17,24) /110, 97,116,101,115, 58, 32,101/ + data (st0007(iyy),iyy=25,32) / 99,108,105,112,116,105, 99, 10/ + data (st0007(iyy),iyy=33,33) / 0/ + data (st0008(iyy),iyy= 1, 8) / 35, 32, 32, 32, 32, 32, 77, 74/ + data (st0008(iyy),iyy= 9,16) / 68, 58, 32, 37, 48, 46, 53,102/ + data (st0008(iyy),iyy=17,24) / 32, 69,112,111, 99,104, 58, 32/ + data (st0008(iyy),iyy=25,32) / 74, 37, 48, 46, 56,102, 32, 66/ + data (st0008(iyy),iyy=33,39) / 37, 48, 46, 56,102, 10, 0/ + data (st0009(iyy),iyy= 1, 8) / 35, 32, 37,115, 58, 32, 37,115/ + data (st0009(iyy),iyy= 9,16) / 32, 32, 67,111,111,114,100,105/ + data (st0009(iyy),iyy=17,24) /110, 97,116,101,115, 58, 32,103/ + data (st0009(iyy),iyy=25,32) / 97,108, 97, 99,116,105, 99, 10/ + data (st0009(iyy),iyy=33,33) / 0/ + data (st0010(iyy),iyy= 1, 8) / 35, 32, 32, 32, 32, 32, 77, 74/ + data (st0010(iyy),iyy= 9,16) / 68, 58, 32, 37, 48, 46, 53,102/ + data (st0010(iyy),iyy=17,24) / 32, 69,112,111, 99,104, 58, 32/ + data (st0010(iyy),iyy=25,32) / 74, 37, 48, 46, 56,102, 32, 66/ + data (st0010(iyy),iyy=33,39) / 37, 48, 46, 56,102, 10, 0/ + data (st0011(iyy),iyy= 1, 8) / 35, 32, 37,115, 58, 32, 37,115/ + data (st0011(iyy),iyy= 9,16) / 32, 32, 67,111,111,114,100,105/ + data (st0011(iyy),iyy=17,24) /110, 97,116,101,115, 58, 32,115/ + data (st0011(iyy),iyy=25,32) /117,112,101,114,103, 97,108, 97/ + data (st0011(iyy),iyy=33,38) / 99,116,105, 99, 10, 0/ + data (st0012(iyy),iyy= 1, 8) / 35, 32, 32, 32, 32, 32, 77, 74/ + data (st0012(iyy),iyy= 9,16) / 68, 58, 32, 37, 48, 46, 53,102/ + data (st0012(iyy),iyy=17,24) / 32, 69,112,111, 99,104, 58, 32/ + data (st0012(iyy),iyy=25,32) / 74, 37, 48, 46, 56,102, 32, 66/ + data (st0012(iyy),iyy=33,39) / 37, 48, 46, 56,102, 10, 0/ + call smark (sp) + call salloc (radecr, 255 , 2) + sw0001=(ctype) + goto 110 +120 continue + if (.not.(skwrdr (radecs, memc(radecr), 255 , st0001) .le. 0 + * )) goto 130 + call xstrcy(st0002, memc(radecr), 255 ) +130 continue + call strupr (memc(radecr)) + call fprinf (fd, st0003) + call pargsr (label) + call pargsr (system) + call pargsr (memc(radecr)) + sw0002=(radecs) + goto 140 +150 continue + call fprinf (fd, st0004) + call pargd (epoch) + if (.not.(((epoch).eq.1.6d308))) goto 160 + call pargd (1.6d308) + call pargd (1.6d308) + goto 161 +160 continue + call pargd (slepj(epoch)) + call pargd (slepb(epoch)) +161 continue + goto 141 +170 continue + call fprinf (fd, st0005) + call pargd (equinx) + call pargd (slepj(epoch)) + call pargd (epoch) + goto 141 +180 continue + call fprinf (fd, st0006) + call pargd (equinx) + call pargd (slepb(epoch)) + call pargd (epoch) + goto 141 +140 continue + sw0002=sw0002-2 + if (sw0002.lt.1.or.sw0002.gt.3) goto 180 + goto (170,170,150),sw0002 +141 continue + goto 111 +190 continue + call fprinf (fd, st0007) + call pargsr (label) + call pargsr (system) + call fprinf (fd, st0008) + call pargd (epoch) + if (.not.(((epoch).eq.1.6d308))) goto 200 + call pargd (1.6d308) + call pargd (1.6d308) + goto 201 +200 continue + call pargd (slepj(epoch)) + call pargd (slepb(epoch)) +201 continue + goto 111 +210 continue + call fprinf (fd, st0009) + call pargsr (label) + call pargsr (system) + call fprinf (fd, st0010) + call pargd (epoch) + call pargd (slepj(epoch)) + call pargd (slepb(epoch)) + goto 111 +220 continue + call fprinf (fd, st0011) + call pargsr (label) + call pargsr (system) + call fprinf (fd, st0012) + call pargd (epoch) + call pargd (slepj(epoch)) + call pargd (slepb(epoch)) + goto 111 +110 continue + if (sw0001.lt.1.or.sw0001.gt.4) goto 111 + goto (120,190,210,220),sw0001 +111 continue + call sfree (sp) +100 return + end + subroutine skimpt (label, images, ctype, lngax, latax, wtype, + *ptype, radecs, equinx, epoch) + integer ctype + integer lngax + integer latax + integer wtype + integer ptype + integer radecs + double precision equinx + double precision epoch + integer*2 label(*) + integer*2 images(*) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer sp + integer imname + integer projsr + integer wcsstr + integer radecr + double precision slepj + double precision slepb + integer skwrdr + integer sw0001,sw0002 + integer*2 st0001(114) + integer*2 st0002(7) + integer*2 st0003(28) + integer*2 st0004(6) + integer*2 st0005(30) + integer*2 st0006(4) + integer*2 st0007(47) + integer*2 st0008(32) + integer*2 st0009(37) + integer*2 st0010(48) + integer*2 st0011(30) + integer*2 st0012(48) + integer*2 st0013(30) + integer*2 st0014(51) + integer*2 st0015(27) + integer*2 st0016(37) + integer*2 st0017(51) + integer*2 st0018(27) + integer*2 st0019(38) + integer*2 st0020(51) + integer*2 st0021(32) + integer*2 st0022(37) + save + integer iyy + data (st0001(iyy),iyy= 1, 8) /124,108,105,110,124, 97,122,112/ + data (st0001(iyy),iyy= 9,16) /124,116, 97,110,124,115,105,110/ + data (st0001(iyy),iyy=17,24) /124,115,116,103,124, 97,114, 99/ + data (st0001(iyy),iyy=25,32) /124,122,112,110,124,122,101, 97/ + data (st0001(iyy),iyy=33,40) /124, 97,105,114,124, 99,121,112/ + data (st0001(iyy),iyy=41,48) /124, 99, 97,114,124,109,101,114/ + data (st0001(iyy),iyy=49,56) /124, 99,101, 97,124, 99,111,112/ + data (st0001(iyy),iyy=57,64) /124, 99,111,100,124, 99,111,101/ + data (st0001(iyy),iyy=65,72) /124, 99,111,111,124, 98,111,110/ + data (st0001(iyy),iyy=73,80) /124,112, 99,111,124,103,108,115/ + data (st0001(iyy),iyy=81,88) /124,112, 97,114,124, 97,105,116/ + data (st0001(iyy),iyy=89,96) /124,109,111,108,124, 99,115, 99/ + data (st0001(iyy),iyy=97,104) /124,113,115, 99,124,116,115, 99/ + data (st0001(iyy),iyy=105,112) /124,116,110,120,124,122,112,120/ + data (st0001(iyy),iyy=113,114) /124, 0/ + data st0002 /108,105,110,101, 97,114, 0/ + data (st0003(iyy),iyy= 1, 8) /124,108,111,103,105, 99, 97,108/ + data (st0003(iyy),iyy= 9,16) /124,116,118,124,112,104,121,115/ + data (st0003(iyy),iyy=17,24) /105, 99, 97,108,124,119,111,114/ + data (st0003(iyy),iyy=25,28) /108,100,124, 0/ + data st0004 /119,111,114,108,100, 0/ + data (st0005(iyy),iyy= 1, 8) /124,102,107, 52,124,102,107, 52/ + data (st0005(iyy),iyy= 9,16) / 45,110,111, 45,101,124,102,107/ + data (st0005(iyy),iyy=17,24) / 53,124,105, 99,114,115,124,103/ + data (st0005(iyy),iyy=25,30) / 97,112,112,116,124, 0/ + data st0006 / 70, 75, 53, 0/ + data (st0007(iyy),iyy= 1, 8) / 37,115, 58, 32, 37,115, 32, 37/ + data (st0007(iyy),iyy= 9,16) /115, 32, 32, 80,114,111,106,101/ + data (st0007(iyy),iyy=17,24) / 99,116,105,111,110, 58, 32, 37/ + data (st0007(iyy),iyy=25,32) /115, 32, 32, 82, 97, 47, 68,101/ + data (st0007(iyy),iyy=33,40) / 99, 32, 97,120,101,115, 58, 32/ + data (st0007(iyy),iyy=41,47) / 37,100, 47, 37,100, 10, 0/ + data (st0008(iyy),iyy= 1, 8) / 32, 32, 32, 32, 67,111,111,114/ + data (st0008(iyy),iyy= 9,16) /100,105,110, 97,116,101,115, 58/ + data (st0008(iyy),iyy=17,24) / 32,101,113,117, 97,116,111,114/ + data (st0008(iyy),iyy=25,32) /105, 97,108, 32, 37,115, 10, 0/ + data (st0009(iyy),iyy= 1, 8) / 32, 32, 32, 32, 77, 74, 68, 58/ + data (st0009(iyy),iyy= 9,16) / 32, 37, 48, 46, 53,102, 32, 69/ + data (st0009(iyy),iyy=17,24) /112,111, 99,104, 58, 32, 74, 37/ + data (st0009(iyy),iyy=25,32) / 48, 46, 56,102, 32, 66, 37, 48/ + data (st0009(iyy),iyy=33,37) / 46, 56,102, 10, 0/ + data (st0010(iyy),iyy= 1, 8) / 32, 32, 32, 32, 67,111,111,114/ + data (st0010(iyy),iyy= 9,16) /100,105,110, 97,116,101,115, 58/ + data (st0010(iyy),iyy=17,24) / 32,101,113,117, 97,116,111,114/ + data (st0010(iyy),iyy=25,32) /105, 97,108, 32, 37,115, 32, 69/ + data (st0010(iyy),iyy=33,40) /113,117,105,110,111,120, 58, 32/ + data (st0010(iyy),iyy=41,48) / 74, 37, 48, 46, 51,102, 10, 0/ + data (st0011(iyy),iyy= 1, 8) / 32, 32, 32, 32, 69,112,111, 99/ + data (st0011(iyy),iyy= 9,16) /104, 58, 32, 74, 37, 48, 46, 56/ + data (st0011(iyy),iyy=17,24) /102, 32, 77, 74, 68, 58, 32, 37/ + data (st0011(iyy),iyy=25,30) / 48, 46, 53,102, 10, 0/ + data (st0012(iyy),iyy= 1, 8) / 32, 32, 32, 32, 67,111,111,114/ + data (st0012(iyy),iyy= 9,16) /100,105,110, 97,116,101,115, 58/ + data (st0012(iyy),iyy=17,24) / 32,101,113,117, 97,116,111,114/ + data (st0012(iyy),iyy=25,32) /105, 97,108, 32, 37,115, 32, 69/ + data (st0012(iyy),iyy=33,40) /113,117,105,110,111,120, 58, 32/ + data (st0012(iyy),iyy=41,48) / 66, 37, 48, 46, 51,102, 10, 0/ + data (st0013(iyy),iyy= 1, 8) / 32, 32, 32, 32, 69,112,111, 99/ + data (st0013(iyy),iyy= 9,16) /104, 58, 32, 66, 37, 48, 46, 56/ + data (st0013(iyy),iyy=17,24) /102, 32, 77, 74, 68, 58, 32, 37/ + data (st0013(iyy),iyy=25,30) / 48, 46, 53,102, 10, 0/ + data (st0014(iyy),iyy= 1, 8) / 37,115, 58, 32, 37,115, 32, 37/ + data (st0014(iyy),iyy= 9,16) /115, 32, 32, 80,114,111,106,101/ + data (st0014(iyy),iyy=17,24) / 99,116,105,111,110, 58, 32, 37/ + data (st0014(iyy),iyy=25,32) /115, 32, 32, 69,108,111,110,103/ + data (st0014(iyy),iyy=33,40) / 47, 69,108, 97,116, 32, 97,120/ + data (st0014(iyy),iyy=41,48) /101,115, 58, 32, 37,100, 47, 37/ + data (st0014(iyy),iyy=49,51) /100, 10, 0/ + data (st0015(iyy),iyy= 1, 8) / 32, 32, 32, 32, 67,111,111,114/ + data (st0015(iyy),iyy= 9,16) /100,105,110, 97,116,101,115, 58/ + data (st0015(iyy),iyy=17,24) / 32,101, 99,108,105,112,116,105/ + data (st0015(iyy),iyy=25,27) / 99, 10, 0/ + data (st0016(iyy),iyy= 1, 8) / 32, 32, 32, 32, 77, 74, 68, 58/ + data (st0016(iyy),iyy= 9,16) / 32, 37, 48, 46, 53,102, 32, 69/ + data (st0016(iyy),iyy=17,24) /112,111, 99,104, 58, 32, 74, 37/ + data (st0016(iyy),iyy=25,32) / 48, 46, 56,102, 32, 66, 37, 48/ + data (st0016(iyy),iyy=33,37) / 46, 56,102, 10, 0/ + data (st0017(iyy),iyy= 1, 8) / 37,115, 58, 32, 37,115, 32, 37/ + data (st0017(iyy),iyy= 9,16) /115, 32, 32, 80,114,111,106,101/ + data (st0017(iyy),iyy=17,24) / 99,116,105,111,110, 58, 32, 37/ + data (st0017(iyy),iyy=25,32) /115, 32, 32, 71,108,111,110,103/ + data (st0017(iyy),iyy=33,40) / 47, 71,108, 97,116, 32, 97,120/ + data (st0017(iyy),iyy=41,48) /101,115, 58, 32, 37,100, 47, 37/ + data (st0017(iyy),iyy=49,51) /100, 10, 0/ + data (st0018(iyy),iyy= 1, 8) / 32, 32, 32, 32, 67,111,111,114/ + data (st0018(iyy),iyy= 9,16) /100,105,110, 97,116,101,115, 58/ + data (st0018(iyy),iyy=17,24) / 32,103, 97,108, 97, 99,116,105/ + data (st0018(iyy),iyy=25,27) / 99, 10, 0/ + data (st0019(iyy),iyy= 1, 8) / 32, 32, 32, 32, 77, 74, 68, 58/ + data (st0019(iyy),iyy= 9,16) / 32, 37, 48, 46, 53,102, 32, 32/ + data (st0019(iyy),iyy=17,24) / 69,112,111, 99,104, 58, 32, 74/ + data (st0019(iyy),iyy=25,32) / 37, 48, 46, 56,102, 32, 66, 37/ + data (st0019(iyy),iyy=33,38) / 48, 46, 56,102, 10, 0/ + data (st0020(iyy),iyy= 1, 8) / 37,115, 58, 32, 37,115, 32, 37/ + data (st0020(iyy),iyy= 9,16) /115, 32, 32, 80,114,111,106,101/ + data (st0020(iyy),iyy=17,24) / 99,116,105,111,110, 58, 32, 37/ + data (st0020(iyy),iyy=25,32) /115, 32, 32, 83,108,111,110,103/ + data (st0020(iyy),iyy=33,40) / 47, 83,108, 97,116, 32, 97,120/ + data (st0020(iyy),iyy=41,48) /101,115, 58, 32, 37,100, 47, 37/ + data (st0020(iyy),iyy=49,51) /100, 10, 0/ + data (st0021(iyy),iyy= 1, 8) / 32, 32, 32, 32, 67,111,111,114/ + data (st0021(iyy),iyy= 9,16) /100,105,110, 97,116,101,115, 58/ + data (st0021(iyy),iyy=17,24) / 32,115,117,112,101,114,103, 97/ + data (st0021(iyy),iyy=25,32) /108, 97, 99,116,105, 99, 10, 0/ + data (st0022(iyy),iyy= 1, 8) / 32, 32, 32, 32, 77, 74, 68, 58/ + data (st0022(iyy),iyy= 9,16) / 32, 37, 48, 46, 53,102, 32, 69/ + data (st0022(iyy),iyy=17,24) /112,111, 99,104, 58, 32, 74, 37/ + data (st0022(iyy),iyy=25,32) / 48, 46, 56,102, 32, 66, 37, 48/ + data (st0022(iyy),iyy=33,37) / 46, 56,102, 10, 0/ + call smark (sp) + call salloc (imname, 255 , 2) + call salloc (projsr, 255 , 2) + call salloc (wcsstr, 255 , 2) + call salloc (radecr, 255 , 2) + call sscan (images) + call gargwd (memc(imname), 255 ) + if (.not.(skwrdr (wtype, memc(projsr), 255 , st0001) .le. 0)) + * goto 110 + call xstrcy(st0002, memc(projsr), 255 ) +110 continue + call strupr (memc(projsr)) + if (.not.(skwrdr (ptype, memc(wcsstr), 255 , st0003) .le. 0)) + * goto 120 + call xstrcy(st0004, memc(wcsstr), 255 ) +120 continue + call strlwr (memc(wcsstr)) + sw0001=(ctype) + goto 130 +140 continue + if (.not.(skwrdr (radecs, memc(radecr), 255 , st0005) .le. 0 + * )) goto 150 + call xstrcy(st0006, memc(radecr), 255 ) +150 continue + call strupr (memc(radecr)) + call xprinf( st0007) + call pargsr (label) + call pargsr (memc(imname)) + call pargsr (memc(wcsstr)) + call pargsr (memc(projsr)) + call pargi (lngax) + call pargi (latax) + sw0002=(radecs) + goto 160 +170 continue + call xprinf(st0008) + call pargsr (memc(radecr)) + call xprinf(st0009) + call pargd (epoch) + if (.not.(((epoch).eq.1.6d308))) goto 180 + call pargd (1.6d308) + call pargd (1.6d308) + goto 181 +180 continue + call pargd (slepj(epoch)) + call pargd (slepb(epoch)) +181 continue + goto 161 +190 continue + call xprinf(st0010) + call pargsr (memc(radecr)) + call pargd (equinx) + call xprinf(st0011) + call pargd (slepj (epoch)) + call pargd (epoch) + goto 161 +200 continue + call xprinf(st0012) + call pargsr (memc(radecr)) + call pargd (equinx) + call xprinf(st0013) + call pargd (slepb (epoch)) + call pargd (epoch) + goto 161 +160 continue + sw0002=sw0002-2 + if (sw0002.lt.1.or.sw0002.gt.3) goto 200 + goto (190,190,170),sw0002 +161 continue + goto 131 +210 continue + call xprinf( st0014) + call pargsr (label) + call pargsr (memc(imname)) + call pargsr (memc(wcsstr)) + call pargsr (memc(projsr)) + call pargi (lngax) + call pargi (latax) + call xprinf(st0015) + call xprinf(st0016) + call pargd (epoch) + if (.not.(((epoch).eq.1.6d308))) goto 220 + call pargd (1.6d308) + call pargd (1.6d308) + goto 221 +220 continue + call pargd (slepj(epoch)) + call pargd (slepb(epoch)) +221 continue + goto 131 +230 continue + call xprinf( st0017) + call pargsr (label) + call pargsr (memc(imname)) + call pargsr (memc(wcsstr)) + call pargsr (memc(projsr)) + call pargi (lngax) + call pargi (latax) + call xprinf(st0018) + call xprinf(st0019) + call pargd (epoch) + call pargd (slepj (epoch)) + call pargd (slepb (epoch)) + goto 131 +240 continue + call xprinf( st0020) + call pargsr (label) + call pargsr (memc(imname)) + call pargsr (memc(wcsstr)) + call pargsr (memc(projsr)) + call pargi (lngax) + call pargi (latax) + call xprinf(st0021) + call xprinf(st0022) + call pargd (epoch) + call pargd (slepj (epoch)) + call pargd (slepb (epoch)) + goto 131 +130 continue + if (sw0001.lt.1.or.sw0001.gt.4) goto 131 + goto (140,210,230,240),sw0001 +131 continue + call sfree (sp) +100 return + end + subroutine skimwe (fd, label, images, ctype, lngax, latax, wtype, + *ptype, radecs, equinx, epoch) + integer fd + integer ctype + integer lngax + integer latax + integer wtype + integer ptype + integer radecs + double precision equinx + double precision epoch + integer*2 label(*) + integer*2 images(*) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer sp + integer imname + integer projsr + integer wcsstr + integer radecr + double precision slepj + double precision slepb + integer skwrdr + integer sw0001,sw0002 + integer*2 st0001(114) + integer*2 st0002(7) + integer*2 st0003(28) + integer*2 st0004(6) + integer*2 st0005(30) + integer*2 st0006(4) + integer*2 st0007(49) + integer*2 st0008(34) + integer*2 st0009(39) + integer*2 st0010(50) + integer*2 st0011(32) + integer*2 st0012(50) + integer*2 st0013(32) + integer*2 st0014(53) + integer*2 st0015(29) + integer*2 st0016(40) + integer*2 st0017(53) + integer*2 st0018(29) + integer*2 st0019(39) + integer*2 st0020(53) + integer*2 st0021(34) + integer*2 st0022(39) + save + integer iyy + data (st0001(iyy),iyy= 1, 8) /124,108,105,110,124, 97,122,112/ + data (st0001(iyy),iyy= 9,16) /124,116, 97,110,124,115,105,110/ + data (st0001(iyy),iyy=17,24) /124,115,116,103,124, 97,114, 99/ + data (st0001(iyy),iyy=25,32) /124,122,112,110,124,122,101, 97/ + data (st0001(iyy),iyy=33,40) /124, 97,105,114,124, 99,121,112/ + data (st0001(iyy),iyy=41,48) /124, 99, 97,114,124,109,101,114/ + data (st0001(iyy),iyy=49,56) /124, 99,101, 97,124, 99,111,112/ + data (st0001(iyy),iyy=57,64) /124, 99,111,100,124, 99,111,101/ + data (st0001(iyy),iyy=65,72) /124, 99,111,111,124, 98,111,110/ + data (st0001(iyy),iyy=73,80) /124,112, 99,111,124,103,108,115/ + data (st0001(iyy),iyy=81,88) /124,112, 97,114,124, 97,105,116/ + data (st0001(iyy),iyy=89,96) /124,109,111,108,124, 99,115, 99/ + data (st0001(iyy),iyy=97,104) /124,113,115, 99,124,116,115, 99/ + data (st0001(iyy),iyy=105,112) /124,116,110,120,124,122,112,120/ + data (st0001(iyy),iyy=113,114) /124, 0/ + data st0002 /108,105,110,101, 97,114, 0/ + data (st0003(iyy),iyy= 1, 8) /124,108,111,103,105, 99, 97,108/ + data (st0003(iyy),iyy= 9,16) /124,116,118,124,112,104,121,115/ + data (st0003(iyy),iyy=17,24) /105, 99, 97,108,124,119,111,114/ + data (st0003(iyy),iyy=25,28) /108,100,124, 0/ + data st0004 /119,111,114,108,100, 0/ + data (st0005(iyy),iyy= 1, 8) /124,102,107, 52,124,102,107, 52/ + data (st0005(iyy),iyy= 9,16) / 45,110,111, 45,101,124,102,107/ + data (st0005(iyy),iyy=17,24) / 53,124,105, 99,114,115,124,103/ + data (st0005(iyy),iyy=25,30) / 97,112,112,116,124, 0/ + data st0006 / 70, 75, 53, 0/ + data (st0007(iyy),iyy= 1, 8) / 35, 32, 37,115, 58, 32, 37,115/ + data (st0007(iyy),iyy= 9,16) / 32, 37,115, 32, 32, 80,114,111/ + data (st0007(iyy),iyy=17,24) /106,101, 99,116,105,111,110, 58/ + data (st0007(iyy),iyy=25,32) / 32, 37,115, 32, 32, 82, 97, 47/ + data (st0007(iyy),iyy=33,40) / 68,101, 99, 32, 97,120,101,115/ + data (st0007(iyy),iyy=41,48) / 58, 32, 37,100, 47, 37,100, 10/ + data (st0007(iyy),iyy=49,49) / 0/ + data (st0008(iyy),iyy= 1, 8) / 35, 32, 32, 32, 32, 32, 67,111/ + data (st0008(iyy),iyy= 9,16) /111,114,100,105,110, 97,116,101/ + data (st0008(iyy),iyy=17,24) /115, 58, 32,101,113,117, 97,116/ + data (st0008(iyy),iyy=25,32) /111,114,105, 97,108, 32, 37,115/ + data (st0008(iyy),iyy=33,34) / 10, 0/ + data (st0009(iyy),iyy= 1, 8) / 35, 32, 32, 32, 32, 32, 77, 74/ + data (st0009(iyy),iyy= 9,16) / 68, 58, 32, 37, 48, 46, 53,102/ + data (st0009(iyy),iyy=17,24) / 32, 69,112,111, 99,104, 58, 32/ + data (st0009(iyy),iyy=25,32) / 74, 37, 48, 46, 56,102, 32, 66/ + data (st0009(iyy),iyy=33,39) / 37, 48, 46, 56,102, 10, 0/ + data (st0010(iyy),iyy= 1, 8) / 35, 32, 32, 32, 32, 32, 67,111/ + data (st0010(iyy),iyy= 9,16) /111,114,100,105,110, 97,116,101/ + data (st0010(iyy),iyy=17,24) /115, 58, 32,101,113,117, 97,116/ + data (st0010(iyy),iyy=25,32) /111,114,105, 97,108, 32, 37,115/ + data (st0010(iyy),iyy=33,40) / 32, 69,113,117,105,110,111,120/ + data (st0010(iyy),iyy=41,48) / 58, 32, 74, 37, 48, 46, 51,102/ + data (st0010(iyy),iyy=49,50) / 10, 0/ + data (st0011(iyy),iyy= 1, 8) / 35, 32, 32, 32, 32, 32, 69,112/ + data (st0011(iyy),iyy= 9,16) /111, 99,104, 58, 32, 74, 37, 48/ + data (st0011(iyy),iyy=17,24) / 46, 56,102, 32, 77, 74, 68, 58/ + data (st0011(iyy),iyy=25,32) / 32, 37, 48, 46, 53,102, 10, 0/ + data (st0012(iyy),iyy= 1, 8) / 35, 32, 32, 32, 32, 32, 67,111/ + data (st0012(iyy),iyy= 9,16) /111,114,100,105,110, 97,116,101/ + data (st0012(iyy),iyy=17,24) /115, 58, 32,101,113,117, 97,116/ + data (st0012(iyy),iyy=25,32) /111,114,105, 97,108, 32, 37,115/ + data (st0012(iyy),iyy=33,40) / 32, 69,113,117,105,110,111,120/ + data (st0012(iyy),iyy=41,48) / 58, 32, 66, 37, 48, 46, 51,102/ + data (st0012(iyy),iyy=49,50) / 10, 0/ + data (st0013(iyy),iyy= 1, 8) / 35, 32, 32, 32, 32, 32, 69,112/ + data (st0013(iyy),iyy= 9,16) /111, 99,104, 58, 32, 66, 37, 48/ + data (st0013(iyy),iyy=17,24) / 46, 56,102, 32, 77, 74, 68, 58/ + data (st0013(iyy),iyy=25,32) / 32, 37, 48, 46, 53,102, 10, 0/ + data (st0014(iyy),iyy= 1, 8) / 35, 32, 37,115, 58, 32, 37,115/ + data (st0014(iyy),iyy= 9,16) / 32, 37,115, 32, 32, 80,114,111/ + data (st0014(iyy),iyy=17,24) /106,101, 99,116,105,111,110, 58/ + data (st0014(iyy),iyy=25,32) / 32, 37,115, 32, 32, 69,108,111/ + data (st0014(iyy),iyy=33,40) /110,103, 47, 69,108, 97,116, 32/ + data (st0014(iyy),iyy=41,48) / 97,120,101,115, 58, 32, 37,100/ + data (st0014(iyy),iyy=49,53) / 47, 37,100, 10, 0/ + data (st0015(iyy),iyy= 1, 8) / 35, 32, 32, 32, 32, 32, 67,111/ + data (st0015(iyy),iyy= 9,16) /111,114,100,105,110, 97,116,101/ + data (st0015(iyy),iyy=17,24) /115, 58, 32,101, 99,108,105,112/ + data (st0015(iyy),iyy=25,29) /116,105, 99, 10, 0/ + data (st0016(iyy),iyy= 1, 8) / 35, 32, 32, 32, 32, 32, 77, 74/ + data (st0016(iyy),iyy= 9,16) / 68, 58, 32, 37, 48, 46, 53,102/ + data (st0016(iyy),iyy=17,24) / 32, 32, 69,112,111, 99,104, 58/ + data (st0016(iyy),iyy=25,32) / 32, 74, 37, 48, 46, 56,102, 32/ + data (st0016(iyy),iyy=33,40) / 66, 37, 48, 46, 56,102, 10, 0/ + data (st0017(iyy),iyy= 1, 8) / 35, 32, 37,115, 58, 32, 37,115/ + data (st0017(iyy),iyy= 9,16) / 32, 37,115, 32, 32, 80,114,111/ + data (st0017(iyy),iyy=17,24) /106,101, 99,116,105,111,110, 58/ + data (st0017(iyy),iyy=25,32) / 32, 37,115, 32, 32, 71,108,111/ + data (st0017(iyy),iyy=33,40) /110,103, 47, 71,108, 97,116, 32/ + data (st0017(iyy),iyy=41,48) / 97,120,101,115, 58, 32, 37,100/ + data (st0017(iyy),iyy=49,53) / 47, 37,100, 10, 0/ + data (st0018(iyy),iyy= 1, 8) / 35, 32, 32, 32, 32, 32, 67,111/ + data (st0018(iyy),iyy= 9,16) /111,114,100,105,110, 97,116,101/ + data (st0018(iyy),iyy=17,24) /115, 58, 32,103, 97,108, 97, 99/ + data (st0018(iyy),iyy=25,29) /116,105, 99, 10, 0/ + data (st0019(iyy),iyy= 1, 8) / 35, 32, 32, 32, 32, 32, 77, 74/ + data (st0019(iyy),iyy= 9,16) / 68, 58, 32, 37, 48, 46, 53,102/ + data (st0019(iyy),iyy=17,24) / 32, 69,112,111, 99,104, 58, 32/ + data (st0019(iyy),iyy=25,32) / 74, 37, 48, 46, 56,102, 32, 66/ + data (st0019(iyy),iyy=33,39) / 37, 48, 46, 56,102, 10, 0/ + data (st0020(iyy),iyy= 1, 8) / 35, 32, 37,115, 58, 32, 37,115/ + data (st0020(iyy),iyy= 9,16) / 32, 37,115, 32, 32, 80,114,111/ + data (st0020(iyy),iyy=17,24) /106,101, 99,116,105,111,110, 58/ + data (st0020(iyy),iyy=25,32) / 32, 37,115, 32, 32, 83,108,111/ + data (st0020(iyy),iyy=33,40) /110,103, 47, 83,108, 97,116, 32/ + data (st0020(iyy),iyy=41,48) / 97,120,101,115, 58, 32, 37,100/ + data (st0020(iyy),iyy=49,53) / 47, 37,100, 10, 0/ + data (st0021(iyy),iyy= 1, 8) / 35, 32, 32, 32, 32, 32, 67,111/ + data (st0021(iyy),iyy= 9,16) /111,114,100,105,110, 97,116,101/ + data (st0021(iyy),iyy=17,24) /115, 58, 32,115,117,112,101,114/ + data (st0021(iyy),iyy=25,32) /103, 97,108, 97, 99,116,105, 99/ + data (st0021(iyy),iyy=33,34) / 10, 0/ + data (st0022(iyy),iyy= 1, 8) / 35, 32, 32, 32, 32, 32, 77, 74/ + data (st0022(iyy),iyy= 9,16) / 68, 58, 32, 37, 48, 46, 53,102/ + data (st0022(iyy),iyy=17,24) / 32, 69,112,111, 99,104, 58, 32/ + data (st0022(iyy),iyy=25,32) / 74, 37, 48, 46, 56,102, 32, 66/ + data (st0022(iyy),iyy=33,39) / 37, 48, 46, 56,102, 10, 0/ + call smark (sp) + call salloc (imname, 255 , 2) + call salloc (projsr, 255 , 2) + call salloc (wcsstr, 255 , 2) + call salloc (radecr, 255 , 2) + call sscan (images) + call gargwd (memc(imname), 255 ) + if (.not.(skwrdr (wtype, memc(projsr), 255 , st0001) .le. 0)) + * goto 110 + call xstrcy(st0002, memc(projsr), 255 ) +110 continue + call strupr (memc(projsr)) + if (.not.(skwrdr (ptype, memc(wcsstr), 255 , st0003) .le. 0)) + * goto 120 + call xstrcy(st0004, memc(wcsstr), 255 ) +120 continue + call strlwr (memc(wcsstr)) + sw0001=(ctype) + goto 130 +140 continue + if (.not.(skwrdr (radecs, memc(radecr), 255 , st0005) .le. 0 + * )) goto 150 + call xstrcy(st0006, memc(radecr), 255 ) +150 continue + call strupr (memc(radecr)) + call fprinf (fd, st0007) + call pargsr (label) + call pargsr (memc(imname)) + call pargsr (memc(wcsstr)) + call pargsr (memc(projsr)) + call pargi (lngax) + call pargi (latax) + sw0002=(radecs) + goto 160 +170 continue + call fprinf (fd, st0008) + call pargsr (memc(radecr)) + call fprinf (fd, st0009) + call pargd (epoch) + if (.not.(((epoch).eq.1.6d308))) goto 180 + call pargd (1.6d308) + call pargd (1.6d308) + goto 181 +180 continue + call pargd (slepj(epoch)) + call pargd (slepb(epoch)) +181 continue + goto 161 +190 continue + call fprinf (fd, st0010) + call pargsr (memc(radecr)) + call pargd (equinx) + call fprinf (fd, st0011) + call pargd (slepj(epoch)) + call pargd (epoch) + goto 161 +200 continue + call fprinf (fd, st0012) + call pargsr (memc(radecr)) + call pargd (equinx) + call fprinf (fd, st0013) + call pargd (slepb (epoch)) + call pargd (epoch) + goto 161 +160 continue + sw0002=sw0002-2 + if (sw0002.lt.1.or.sw0002.gt.3) goto 200 + goto (190,190,170),sw0002 +161 continue + goto 131 +210 continue + call fprinf (fd, st0014) + call pargsr (label) + call pargsr (memc(imname)) + call pargsr (memc(wcsstr)) + call pargsr (memc(projsr)) + call pargi (lngax) + call pargi (latax) + call fprinf (fd, st0015) + call fprinf (fd, st0016) + call pargd (epoch) + if (.not.(((epoch).eq.1.6d308))) goto 220 + call pargd (1.6d308) + call pargd (1.6d308) + goto 221 +220 continue + call pargd (slepj(epoch)) + call pargd (slepb(epoch)) +221 continue + goto 131 +230 continue + call fprinf (fd, st0017) + call pargsr (label) + call pargsr (memc(imname)) + call pargsr (memc(wcsstr)) + call pargsr (memc(projsr)) + call pargi (lngax) + call pargi (latax) + call fprinf (fd, st0018) + call fprinf (fd, st0019) + call pargd (epoch) + call pargd (slepj(epoch)) + call pargd (slepb(epoch)) + goto 131 +240 continue + call fprinf (fd, st0020) + call pargsr (label) + call pargsr (memc(imname)) + call pargsr (memc(wcsstr)) + call pargsr (memc(projsr)) + call pargi (lngax) + call pargi (latax) + call fprinf (fd, st0021) + call fprinf (fd, st0022) + call pargd (epoch) + call pargd (slepj(epoch)) + call pargd (slepb(epoch)) + goto 131 +130 continue + if (sw0001.lt.1.or.sw0001.gt.4) goto 131 + goto (140,210,230,240),sw0001 +131 continue + call sfree (sp) +100 return + end +c radecs radecsys +c equinx equinox +c images imagesys +c skwrdr sk_wrdstr +c skiiwe sk_iiwrite +c skiipt sk_iiprint +c skimwe sk_imwrite +c skinwe sk_inwrite +c skimpt sk_imprint +c skinpt sk_inprint +c projsr projstr +c gargwd gargwrd +c fprinf fprintf +c radecr radecstr +c pargsr pargstr diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skwrite.x b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skwrite.x new file mode 100644 index 00000000..2e779b09 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skwrite.x @@ -0,0 +1,510 @@ +include "skywcsdef.h" +include "skywcs.h" + + +# SK_IIPRINT -- Print a summary of the input image or list coordinate system. + +procedure sk_iiprint (label, imagesys, mw, coo) + +char label[ARB] #I the input label +char imagesys[ARB] #I the input image name and wcs +pointer mw #I pointer to the image wcs +pointer coo #I pointer to the coordinate system structure + +begin + if (mw == NULL) + call sk_inprint (label, imagesys, SKY_CTYPE(coo), + SKY_RADECSYS(coo), SKY_EQUINOX(coo), SKY_EPOCH(coo)) + else + call sk_imprint (label, imagesys, SKY_CTYPE(coo), SKY_PLNGAX(coo), + SKY_PLATAX(coo), SKY_WTYPE(coo), SKY_PIXTYPE(coo), + SKY_RADECSYS(coo), SKY_EQUINOX(coo), SKY_EPOCH(coo)) +end + + +# SK_IIWRITE -- Write a summary of the input image or list coordinate system +# to the output file + +procedure sk_iiwrite (fd, label, imagesys, mw, coo) + +int fd #I the output file descriptor +char label[ARB] #I the input label +char imagesys[ARB] #I the input image name and wcs +pointer mw #I pointer to the image wcs +pointer coo #I pointer to the coordinate system structure + +begin + if (mw == NULL) + call sk_inwrite (fd, label, imagesys, SKY_CTYPE(coo), + SKY_RADECSYS(coo), SKY_EQUINOX(coo), SKY_EPOCH(coo)) + else + call sk_imwrite (fd, label, imagesys, SKY_CTYPE(coo), + SKY_PLNGAX(coo), SKY_PLATAX(coo), SKY_WTYPE(coo), + SKY_PIXTYPE(coo), SKY_RADECSYS(coo), SKY_EQUINOX(coo), + SKY_EPOCH(coo)) +end + + +# SK_INPRINT -- Print a summary of the input list coordinate system. +# This should probably be a call to sk_inwrite with the file descriptor +# set to STDOUT to avoid duplication of code. There was a reason for +# having two routines at one point but I can't remember what it was ... + +procedure sk_inprint (label, system, ctype, radecsys, equinox, epoch) + +char label[ARB] #I the input label +char system[ARB] #I the input system +int ctype #I the input coordinate type +int radecsys #I the input equatorial reference system +double equinox #I the input equinox +double epoch #I the input epoch of the observation + +pointer sp, radecstr +double sl_epj(), sl_epb() +int sk_wrdstr() + +begin + call smark (sp) + call salloc (radecstr, SZ_FNAME, TY_CHAR) + + switch (ctype) { + + case CTYPE_EQUATORIAL: + if (sk_wrdstr (radecsys, Memc[radecstr], SZ_FNAME, + EQTYPE_LIST) <= 0) + call strcpy ("FK5", Memc[radecstr], SZ_FNAME) + call strupr (Memc[radecstr]) + call printf ("%s: %s Coordinates: equatorial %s\n") + call pargstr (label) + call pargstr (system) + call pargstr (Memc[radecstr]) + switch (radecsys) { + case EQTYPE_GAPPT: + call printf (" MJD: %0.5f Epoch: J%0.8f B%0.8f\n") + call pargd (epoch) + if (IS_INDEFD(epoch)) { + call pargd (INDEFD) + call pargd (INDEFD) + } else { + call pargd (sl_epj (epoch)) + call pargd (sl_epb (epoch)) + } + case EQTYPE_FK5, EQTYPE_ICRS: + call printf (" Equinox: J%0.3f Epoch: J%0.8f MJD: %0.5f\n") + call pargd (equinox) + call pargd (sl_epj(epoch)) + call pargd (epoch) + default: + call printf (" Equinox: B%0.3f Epoch: B%0.8f MJD: %0.5f\n") + call pargd (equinox) + call pargd (sl_epb(epoch)) + call pargd (epoch) + } + + case CTYPE_ECLIPTIC: + call printf ("%s: %s Coordinates: ecliptic\n") + call pargstr (label) + call pargstr (system) + call printf (" MJD: %0.5f Epoch: J%0.8f B%0.8f\n") + call pargd (epoch) + if (IS_INDEFD(epoch)) { + call pargd (INDEFD) + call pargd (INDEFD) + } else { + call pargd (sl_epj(epoch)) + call pargd (sl_epb(epoch)) + } + + case CTYPE_GALACTIC: + call printf ("%s: %s Coordinates: galactic\n") + call pargstr (label) + call pargstr (system) + call printf (" MJD: %0.5f Epoch: J%0.8f B%0.8f\n") + call pargd (epoch) + call pargd (sl_epj (epoch)) + call pargd (sl_epb (epoch)) + + case CTYPE_SUPERGALACTIC: + call printf ("%s: %s Coordinates: supergalactic\n") + call pargstr (label) + call pargstr (system) + call printf (" MJD: %0.5f Epoch: J%0.8f B%0.8f\n") + call pargd (epoch) + call pargd (sl_epj (epoch)) + call pargd (sl_epb (epoch)) + + } + + call sfree (sp) +end + + +# SK_INWRITE -- Write a summary of the input coordinate system. + +procedure sk_inwrite (fd, label, system, ctype, radecsys, equinox, epoch) + +int fd #I the output file descriptor +char label[ARB] #I the input label +char system[ARB] #I the input system +int ctype #I the input coordinate type +int radecsys #I the input equatorial reference system +double equinox #I the input equinox +double epoch #I the input epoch of the observation + +pointer sp, radecstr +double sl_epj(), sl_epb() +int sk_wrdstr() + +begin + call smark (sp) + call salloc (radecstr, SZ_FNAME, TY_CHAR) + + switch (ctype) { + + case CTYPE_EQUATORIAL: + if (sk_wrdstr (radecsys, Memc[radecstr], SZ_FNAME, + EQTYPE_LIST) <= 0) + call strcpy ("FK5", Memc[radecstr], SZ_FNAME) + call strupr (Memc[radecstr]) + call fprintf (fd, "# %s: %s Coordinates: equatorial %s\n") + call pargstr (label) + call pargstr (system) + call pargstr (Memc[radecstr]) + switch (radecsys) { + case EQTYPE_GAPPT: + call fprintf (fd, "# MJD: %0.5f Epoch: J%0.8f B%0.8f\n") + call pargd (epoch) + if (IS_INDEFD(epoch)) { + call pargd (INDEFD) + call pargd (INDEFD) + } else { + call pargd (sl_epj(epoch)) + call pargd (sl_epb(epoch)) + } + case EQTYPE_FK5, EQTYPE_ICRS: + call fprintf (fd, + "# Equinox: J%0.3f Epoch: J%0.8f MJD: %0.5f\n") + call pargd (equinox) + call pargd (sl_epj(epoch)) + call pargd (epoch) + default: + call fprintf (fd, + "# Equinox: B%0.3f Epoch: B%0.8f MJD: %0.5f\n") + call pargd (equinox) + call pargd (sl_epb(epoch)) + call pargd (epoch) + } + + case CTYPE_ECLIPTIC: + call fprintf (fd, "# %s: %s Coordinates: ecliptic\n") + call pargstr (label) + call pargstr (system) + call fprintf (fd, "# MJD: %0.5f Epoch: J%0.8f B%0.8f\n") + call pargd (epoch) + if (IS_INDEFD(epoch)) { + call pargd (INDEFD) + call pargd (INDEFD) + } else { + call pargd (sl_epj(epoch)) + call pargd (sl_epb(epoch)) + } + + case CTYPE_GALACTIC: + call fprintf (fd, "# %s: %s Coordinates: galactic\n") + call pargstr (label) + call pargstr (system) + call fprintf (fd, "# MJD: %0.5f Epoch: J%0.8f B%0.8f\n") + call pargd (epoch) + call pargd (sl_epj(epoch)) + call pargd (sl_epb(epoch)) + + case CTYPE_SUPERGALACTIC: + call fprintf (fd, "# %s: %s Coordinates: supergalactic\n") + call pargstr (label) + call pargstr (system) + call fprintf (fd, "# MJD: %0.5f Epoch: J%0.8f B%0.8f\n") + call pargd (epoch) + call pargd (sl_epj(epoch)) + call pargd (sl_epb(epoch)) + + } + + call sfree (sp) +end + + +# SK_IMPRINT -- Print a summary of the input image coordinate system. +# This should probably be a call to sk_imwrite with the file descriptor +# set to STDOUT to avoid duplication of code. There was a reason for +# having two routines at one point but I can't remember what it was ... + +procedure sk_imprint (label, imagesys, ctype, lngax, latax, wtype, ptype, + radecsys, equinox, epoch) + +char label[ARB] #I input label +char imagesys[ARB] #I the input image name and system +int ctype #I the image coordinate type +int lngax #I the image ra/glon/elon axis +int latax #I the image dec/glat/elat axis +int wtype #I the image projection type +int ptype #I the image image wcs type +int radecsys #I the image equatorial reference system +double equinox #I the image equinox +double epoch #I the image epoch of the observation + +pointer sp, imname, projstr, wcsstr, radecstr +double sl_epj(), sl_epb() +int sk_wrdstr() + +begin + call smark (sp) + call salloc (imname, SZ_FNAME, TY_CHAR) + call salloc (projstr, SZ_FNAME, TY_CHAR) + call salloc (wcsstr, SZ_FNAME, TY_CHAR) + call salloc (radecstr, SZ_FNAME, TY_CHAR) + + call sscan (imagesys) + call gargwrd (Memc[imname], SZ_FNAME) + if (sk_wrdstr (wtype, Memc[projstr], SZ_FNAME, WTYPE_LIST) <= 0) + call strcpy ("linear", Memc[projstr], SZ_FNAME) + call strupr (Memc[projstr]) + if (sk_wrdstr (ptype, Memc[wcsstr], SZ_FNAME, PIXTYPE_LIST) <= 0) + call strcpy ("world", Memc[wcsstr], SZ_FNAME) + call strlwr (Memc[wcsstr]) + + switch (ctype) { + + case CTYPE_EQUATORIAL: + if (sk_wrdstr (radecsys, Memc[radecstr], SZ_FNAME, + EQTYPE_LIST) <= 0) + call strcpy ("FK5", Memc[radecstr], SZ_FNAME) + call strupr (Memc[radecstr]) + call printf ( + "%s: %s %s Projection: %s Ra/Dec axes: %d/%d\n") + call pargstr (label) + call pargstr (Memc[imname]) + call pargstr (Memc[wcsstr]) + call pargstr (Memc[projstr]) + call pargi (lngax) + call pargi (latax) + switch (radecsys) { + case EQTYPE_GAPPT: + call printf (" Coordinates: equatorial %s\n") + call pargstr (Memc[radecstr]) + call printf (" MJD: %0.5f Epoch: J%0.8f B%0.8f\n") + call pargd (epoch) + if (IS_INDEFD(epoch)) { + call pargd (INDEFD) + call pargd (INDEFD) + } else { + call pargd (sl_epj(epoch)) + call pargd (sl_epb(epoch)) + } + case EQTYPE_FK5, EQTYPE_ICRS: + call printf (" Coordinates: equatorial %s Equinox: J%0.3f\n") + call pargstr (Memc[radecstr]) + call pargd (equinox) + call printf (" Epoch: J%0.8f MJD: %0.5f\n") + call pargd (sl_epj (epoch)) + call pargd (epoch) + default: + call printf (" Coordinates: equatorial %s Equinox: B%0.3f\n") + call pargstr (Memc[radecstr]) + call pargd (equinox) + call printf (" Epoch: B%0.8f MJD: %0.5f\n") + call pargd (sl_epb (epoch)) + call pargd (epoch) + } + + case CTYPE_ECLIPTIC: + call printf ( + "%s: %s %s Projection: %s Elong/Elat axes: %d/%d\n") + call pargstr (label) + call pargstr (Memc[imname]) + call pargstr (Memc[wcsstr]) + call pargstr (Memc[projstr]) + call pargi (lngax) + call pargi (latax) + call printf (" Coordinates: ecliptic\n") + call printf (" MJD: %0.5f Epoch: J%0.8f B%0.8f\n") + call pargd (epoch) + if (IS_INDEFD(epoch)) { + call pargd (INDEFD) + call pargd (INDEFD) + } else { + call pargd (sl_epj(epoch)) + call pargd (sl_epb(epoch)) + } + + case CTYPE_GALACTIC: + call printf ( + "%s: %s %s Projection: %s Glong/Glat axes: %d/%d\n") + call pargstr (label) + call pargstr (Memc[imname]) + call pargstr (Memc[wcsstr]) + call pargstr (Memc[projstr]) + call pargi (lngax) + call pargi (latax) + call printf (" Coordinates: galactic\n") + call printf (" MJD: %0.5f Epoch: J%0.8f B%0.8f\n") + call pargd (epoch) + call pargd (sl_epj (epoch)) + call pargd (sl_epb (epoch)) + + case CTYPE_SUPERGALACTIC: + call printf ( + "%s: %s %s Projection: %s Slong/Slat axes: %d/%d\n") + call pargstr (label) + call pargstr (Memc[imname]) + call pargstr (Memc[wcsstr]) + call pargstr (Memc[projstr]) + call pargi (lngax) + call pargi (latax) + call printf (" Coordinates: supergalactic\n") + call printf (" MJD: %0.5f Epoch: J%0.8f B%0.8f\n") + call pargd (epoch) + call pargd (sl_epj (epoch)) + call pargd (sl_epb (epoch)) + } + + call sfree (sp) +end + + +# SK_IMWRITE -- Write a summary of the image coordinate system to the +# output file. + +procedure sk_imwrite (fd, label, imagesys, ctype, lngax, latax, wtype, ptype, + radecsys, equinox, epoch) + +int fd #I the output file descriptor +char label[ARB] #I input label +char imagesys[ARB] #I the input image name and wcs +int ctype #I the image coordinate type +int lngax #I the image ra/glon/elon axis +int latax #I the image dec/glat/elat axis +int wtype #I the image projection type +int ptype #I the image image wcs type +int radecsys #I the image equatorial reference system +double equinox #I the image equinox +double epoch #I the image epoch of the observation + +pointer sp, imname, projstr, wcsstr, radecstr +double sl_epj(), sl_epb() +int sk_wrdstr() + +begin + call smark (sp) + call salloc (imname, SZ_FNAME, TY_CHAR) + call salloc (projstr, SZ_FNAME, TY_CHAR) + call salloc (wcsstr, SZ_FNAME, TY_CHAR) + call salloc (radecstr, SZ_FNAME, TY_CHAR) + + call sscan (imagesys) + call gargwrd (Memc[imname], SZ_FNAME) + if (sk_wrdstr (wtype, Memc[projstr], SZ_FNAME, WTYPE_LIST) <= 0) + call strcpy ("linear", Memc[projstr], SZ_FNAME) + call strupr (Memc[projstr]) + if (sk_wrdstr (ptype, Memc[wcsstr], SZ_FNAME, PIXTYPE_LIST) <= 0) + call strcpy ("world", Memc[wcsstr], SZ_FNAME) + call strlwr (Memc[wcsstr]) + + switch (ctype) { + + case CTYPE_EQUATORIAL: + if (sk_wrdstr (radecsys, Memc[radecstr], SZ_FNAME, + EQTYPE_LIST) <= 0) + call strcpy ("FK5", Memc[radecstr], SZ_FNAME) + call strupr (Memc[radecstr]) + call fprintf (fd, + "# %s: %s %s Projection: %s Ra/Dec axes: %d/%d\n") + call pargstr (label) + call pargstr (Memc[imname]) + call pargstr (Memc[wcsstr]) + call pargstr (Memc[projstr]) + call pargi (lngax) + call pargi (latax) + switch (radecsys) { + case EQTYPE_GAPPT: + call fprintf (fd, "# Coordinates: equatorial %s\n") + call pargstr (Memc[radecstr]) + call fprintf (fd, "# MJD: %0.5f Epoch: J%0.8f B%0.8f\n") + call pargd (epoch) + if (IS_INDEFD(epoch)) { + call pargd (INDEFD) + call pargd (INDEFD) + } else { + call pargd (sl_epj(epoch)) + call pargd (sl_epb(epoch)) + } + case EQTYPE_FK5, EQTYPE_ICRS: + call fprintf (fd, + "# Coordinates: equatorial %s Equinox: J%0.3f\n") + call pargstr (Memc[radecstr]) + call pargd (equinox) + call fprintf (fd, "# Epoch: J%0.8f MJD: %0.5f\n") + call pargd (sl_epj(epoch)) + call pargd (epoch) + default: + call fprintf (fd, + "# Coordinates: equatorial %s Equinox: B%0.3f\n") + call pargstr (Memc[radecstr]) + call pargd (equinox) + call fprintf (fd, "# Epoch: B%0.8f MJD: %0.5f\n") + call pargd (sl_epb (epoch)) + call pargd (epoch) + } + + case CTYPE_ECLIPTIC: + call fprintf (fd, + "# %s: %s %s Projection: %s Elong/Elat axes: %d/%d\n") + call pargstr (label) + call pargstr (Memc[imname]) + call pargstr (Memc[wcsstr]) + call pargstr (Memc[projstr]) + call pargi (lngax) + call pargi (latax) + call fprintf (fd, "# Coordinates: ecliptic\n") + call fprintf (fd, "# MJD: %0.5f Epoch: J%0.8f B%0.8f\n") + call pargd (epoch) + if (IS_INDEFD(epoch)) { + call pargd (INDEFD) + call pargd (INDEFD) + } else { + call pargd (sl_epj(epoch)) + call pargd (sl_epb(epoch)) + } + + case CTYPE_GALACTIC: + call fprintf (fd, + "# %s: %s %s Projection: %s Glong/Glat axes: %d/%d\n") + call pargstr (label) + call pargstr (Memc[imname]) + call pargstr (Memc[wcsstr]) + call pargstr (Memc[projstr]) + call pargi (lngax) + call pargi (latax) + call fprintf (fd, "# Coordinates: galactic\n") + call fprintf (fd, "# MJD: %0.5f Epoch: J%0.8f B%0.8f\n") + call pargd (epoch) + call pargd (sl_epj(epoch)) + call pargd (sl_epb(epoch)) + + case CTYPE_SUPERGALACTIC: + call fprintf (fd, + "# %s: %s %s Projection: %s Slong/Slat axes: %d/%d\n") + call pargstr (label) + call pargstr (Memc[imname]) + call pargstr (Memc[wcsstr]) + call pargstr (Memc[projstr]) + call pargi (lngax) + call pargi (latax) + call fprintf (fd, "# Coordinates: supergalactic\n") + call fprintf (fd, "# MJD: %0.5f Epoch: J%0.8f B%0.8f\n") + call pargd (epoch) + call pargd (sl_epj(epoch)) + call pargd (sl_epb(epoch)) + } + + call sfree (sp) +end diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skywcs.h b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skywcs.h new file mode 100644 index 00000000..c0c6a3b7 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skywcs.h @@ -0,0 +1,132 @@ +# Public definitions file for the SKYWCS library. + +# Define the SKYWCS library parameters. + +define S_VXOFF 1 +define S_VYOFF 2 +define S_VXSTEP 3 +define S_VYSTEP 4 +define S_EQUINOX 5 +define S_EPOCH 6 +define S_CTYPE 7 +define S_RADECSYS 8 +define S_WTYPE 9 +define S_PLNGAX 10 +define S_PLATAX 11 +define S_XLAX 12 +define S_YLAX 13 +define S_PIXTYPE 14 +define S_NLNGAX 15 +define S_NLATAX 16 +define S_NLNGUNITS 17 +define S_NLATUNITS 18 +define S_COOSYSTEM 19 +define S_STATUS 20 + +# Define the list of supported fundamental coordinate systems. + +define FTYPE_LIST "|fk4|noefk4|fk5|icrs|apparent|ecliptic|galactic|\ +supergalactic|" + +define FTYPE_FK4 1 +define FTYPE_FK4NOE 2 +define FTYPE_FK5 3 +define FTYPE_ICRS 4 +define FTYPE_GAPPT 5 +define FTYPE_ECLIPTIC 6 +define FTYPE_GALACTIC 7 +define FTYPE_SUPERGALACTIC 8 + +# Define the list of supported coordinate systems. + +define CTYPE_LIST "|equatorial|ecliptic|galactic|supergalactic|" + +define CTYPE_EQUATORIAL 1 +define CTYPE_ECLIPTIC 2 +define CTYPE_GALACTIC 3 +define CTYPE_SUPERGALACTIC 4 + +# Define the supported equatoral reference systems. + +define EQTYPE_LIST "|fk4|fk4-no-e|fk5|icrs|gappt|" + +define EQTYPE_FK4 1 +define EQTYPE_FK4NOE 2 +define EQTYPE_FK5 3 +define EQTYPE_ICRS 4 +define EQTYPE_GAPPT 5 + +# Define the input coordinate file longitude latitude units. + +define SKY_LNG_UNITLIST "|degrees|radians|hours|" +define SKY_LAT_UNITLIST "|degrees|radians|" + +define SKY_DEGREES 1 +define SKY_RADIANS 2 +define SKY_HOURS 3 + +# Define the list of supported image sky projection types. + +define WTYPE_LIST "|lin|azp|tan|sin|stg|arc|zpn|zea|air|cyp|car|\ +mer|cea|cop|cod|coe|coo|bon|pco|gls|par|ait|mol|csc|qsc|tsc|tnx|zpx|" + +define PTYPE_LIST "|z|z|z|z|z|z|z|z|z|c|c|c|c|n|n|n|n|c|c|c|c|c|c|c|c|c|\ +x|x|" + +define WTYPE_LIN 1 +define WTYPE_AZP 2 +define WTYPE_TAN 3 +define WTYPE_SIN 4 +define WTYPE_STG 5 +define WTYPE_ARC 6 +define WTYPE_ZPN 7 +define WTYPE_ZEA 8 +define WTYPE_AIR 9 +define WTYPE_CYP 10 +define WTYPE_CAR 11 +define WTYPE_MER 12 +define WTYPE_CEA 13 +define WTYPE_COP 14 +define WTYPE_COD 15 +define WTYPE_COE 16 +define WTYPE_COO 17 +define WTYPE_BON 18 +define WTYPE_PCO 19 +define WTYPE_GLS 20 +define WTYPE_PAR 21 +define WTYPE_AIT 22 +define WTYPE_MOL 23 +define WTYPE_CSC 24 +define WTYPE_QSC 25 +define WTYPE_TSC 26 +define WTYPE_TNX 27 +define WTYPE_ZPX 28 + +define PTYPE_NAMES "|z|c|n|x|" + +define PTYPE_ZEN 1 +define PTYPE_CYL 2 +define PTYPE_CON 3 +define PTYPE_EXP 4 + +# Define the supported image axis types. + +define AXTYPE_LIST "|ra|dec|glon|glat|elon|elat|slon|slat|" + +define AXTYPE_RA 1 +define AXTYPE_DEC 2 +define AXTYPE_GLON 3 +define AXTYPE_GLAT 4 +define AXTYPE_ELON 5 +define AXTYPE_ELAT 6 +define AXTYPE_SLON 7 +define AXTYPE_SLAT 8 + +# Define the supported image pixel coordinate systems. + +define PIXTYPE_LIST "|logical|tv|physical|world|" + +define PIXTYPE_LOGICAL 1 +define PIXTYPE_TV 2 +define PIXTYPE_PHYSICAL 3 +define PIXTYPE_WORLD 4 diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skywcsdef.h b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skywcsdef.h new file mode 100644 index 00000000..433247bd --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skywcsdef.h @@ -0,0 +1,24 @@ +# The SKYWCS library structure. + +define LEN_SKYCOOSTRUCT (30 + SZ_FNAME + 1) + +define SKY_VXOFF Memd[P2D($1)] # logical ra/longitude offset +define SKY_VYOFF Memd[P2D($1+2)] # logical dec/tatitude offset +define SKY_VXSTEP Memd[P2D($1+4)] # logical ra/longitude stepsize +define SKY_VYSTEP Memd[P2D($1+6)] # logical dec/latitude stepsize +define SKY_EQUINOX Memd[P2D($1+8)] # equinox of ra/dec system (B or J) +define SKY_EPOCH Memd[P2D($1+10)] # epoch of observation (MJD) +define SKY_CTYPE Memi[$1+12] # celestial coordinate system code +define SKY_RADECSYS Memi[$1+13] # ra/dec system code +define SKY_WTYPE Memi[$1+14] # sky projection function code +define SKY_PLNGAX Memi[$1+15] # physical ra/longitude axis +define SKY_PLATAX Memi[$1+16] # physical dec/latitude axis +define SKY_XLAX Memi[$1+17] # logical ra/longitude axis +define SKY_YLAX Memi[$1+18] # logical dec/latitude axis +define SKY_PIXTYPE Memi[$1+19] # iraf wcs system code +define SKY_NLNGAX Memi[$1+20] # length of ra/longitude axis +define SKY_NLATAX Memi[$1+21] # length of dec/latitude axis +define SKY_NLNGUNITS Memi[$1+22] # the native ra/longitude units +define SKY_NLATUNITS Memi[$1+23] # the native dec/latitude units +define SKY_STATUS Memi[$1+24] # the status (OK or ERR) +define SKY_COOSYSTEM Memc[P2C($1+25)] # the coordinate system name diff --git a/vendor/x11iraf/ximtool/clients.old/lib/wcsgfterm.f b/vendor/x11iraf/ximtool/clients.old/lib/wcsgfterm.f new file mode 100644 index 00000000..a8f7b191 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/wcsgfterm.f @@ -0,0 +1,89 @@ + subroutine wcsgfm (mw, crpix, crval, cd, ndim) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer mw + integer ndim + double precision crpix(ndim) + double precision crval(ndim) + double precision cd(ndim,ndim) + integer sp + integer r + integer wcd + integer ltv + integer ltm + integer iltm + integer alert + integer errmsg + integer i + integer errcoe + integer errget + logical xerpop + logical xerflg + common /xercom/ xerflg + integer*2 st0001(8) + integer*2 st0002(26) + integer*2 st0003(1) + integer*2 st0004(1) + save + integer iyy + data st0001 / 37,115, 10, 34, 37,115, 34, 0/ + data (st0002(iyy),iyy= 1, 8) / 69,114,114,111,114, 32,100,101/ + data (st0002(iyy),iyy= 9,16) / 99,111,100,105,110,103, 32,105/ + data (st0002(iyy),iyy=17,24) /109, 97,103,101, 32, 87, 67, 83/ + data (st0002(iyy),iyy=25,26) / 58, 0/ + data st0003 / 0/ + data st0004 / 0/ + call smark (sp) + call salloc (r, ndim, 7) + call salloc (wcd, ndim * ndim, 7) + call salloc (ltv, ndim, 7) + call salloc (ltm, ndim * ndim, 7) + call salloc (iltm, ndim * ndim, 7) + call xerpsh + call mwgwtd (mw, memd(r), crval, memd(wcd), ndim) + if (xerflg) goto 112 + call mwgltd (mw, memd(ltm), memd(ltv), ndim) + if (xerflg) goto 112 + call mwvmud (memd(ltm), memd(r), crpix, ndim) + call aaddd (crpix, memd(ltv), crpix, ndim) + call mwinvd (memd(ltm), memd(iltm), ndim) + call mwmmud (memd(wcd), memd(iltm), cd, ndim) +112 if (.not.xerpop()) goto 110 + call salloc (alert, 1023 , 2) + call salloc (errmsg, 1023 , 2) + call aclrd (cd, ndim*ndim) + i=1 +120 if (.not.(i .le. ndim)) goto 122 + crpix(i) = 1.0d0 + crval(i) = 1.0d0 + cd(i,i) = 1.0d0 +121 i=i+1 + goto 120 +122 continue + errcoe = errget (memc(errmsg), 1023 ) + call sprinf (memc(alert), 255 , st0001) + call pargsr (st0002) + call pargsr (memc(errmsg)) + call ximalt (memc(alert), st0003, st0004) +110 continue + call sfree (sp) +100 return + end +c sprinf sprintf +c mwinvd mwinvertd +c mwvmud mwvmuld +c errcoe errcode +c mwgwtd mw_gwtermd +c ximalt xim_alert +c mwmmud mwmmuld +c pargsr pargstr +c wcsgfm wcs_gfterm +c mwgltd mw_gltermd diff --git a/vendor/x11iraf/ximtool/clients.old/lib/wcsgfterm.x b/vendor/x11iraf/ximtool/clients.old/lib/wcsgfterm.x new file mode 100644 index 00000000..8b97a55b --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/wcsgfterm.x @@ -0,0 +1,61 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + + +# WCS_GFTERM -- Compute the output FITS CRPIX, CRVAL, and CD arrays from the +# MWCS LTERM and WTERM. Note that the CD matrix terms are still transposed +# from the usual Fortran order. + +procedure wcs_gfterm (mw, crpix, crval, cd, ndim) + +pointer mw #i the input mwcs pointer +double crpix[ndim] #o the output FITS CRPIX array +double crval[ndim] #o the output FITS CRVAL array +double cd[ndim,ndim] #o the output FITS CD matrix +int ndim #i the dimensionality of the wcs + +pointer sp, r, wcd, ltv, ltm, iltm +pointer alert, errmsg +int i, errcode + +int errget() + +errchk mw_gwtermd, mw_gltermd + +begin + call smark (sp) + call salloc (r, ndim, TY_DOUBLE) + call salloc (wcd, ndim * ndim, TY_DOUBLE) + call salloc (ltv, ndim, TY_DOUBLE) + call salloc (ltm, ndim * ndim, TY_DOUBLE) + call salloc (iltm, ndim * ndim, TY_DOUBLE) + + iferr { + call mw_gwtermd (mw, Memd[r], crval, Memd[wcd], ndim) + call mw_gltermd (mw, Memd[ltm], Memd[ltv], ndim) + call mwvmuld (Memd[ltm], Memd[r], crpix, ndim) + call aaddd (crpix, Memd[ltv], crpix, ndim) + call mwinvertd (Memd[ltm], Memd[iltm], ndim) + call mwmmuld (Memd[wcd], Memd[iltm], cd, ndim) + + } then { + call salloc (alert, SZ_LINE, TY_CHAR) + call salloc (errmsg, SZ_LINE, TY_CHAR) + + # Set up a default value. + call aclrd (cd, ndim*ndim) + for (i=1; i <= ndim; i=i+1) { + crpix[i] = 1.0d0 + crval[i] = 1.0d0 + cd[i,i] = 1.0d0 + } + + # Send alert to the GUI. + errcode = errget (Memc[errmsg], SZ_LINE) + call sprintf (Memc[alert], SZ_FNAME, "%s\n\"%s\"") + call pargstr ("Error decoding image WCS:") + call pargstr (Memc[errmsg]) + call xim_alert (Memc[alert], "", "") + } + + call sfree (sp) +end diff --git a/vendor/x11iraf/ximtool/clients.old/lib/ximtool.f b/vendor/x11iraf/ximtool/clients.old/lib/ximtool.f new file mode 100644 index 00000000..80dabf3f --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/ximtool.f @@ -0,0 +1,510 @@ + integer function ximcot (device, name, type) + integer*2 device(*) + integer*2 name(*) + integer*2 type(*) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer sp + integer cmsg + integer dev + integer buf + integer msglen + integer*2 connet(255 +1) + integer ndopen + integer reopen + integer xstrln + integer ximred + logical streq + external ximonr + integer fdin + integer fdout + integer mode + integer nbuf + integer nr + integer nw + integer*2 buffer(2047+1) + integer ximepa + integer ximstt + integer oldont + integer ximfd + integer ximjmp(64 ) + integer ximert + logical xerpop + logical xerflg + common /xercom/ xerflg + common /ximfd/ fdin, fdout, mode, nbuf, buffer, nr, nw + common /ximcom/ ximfd, ximjmp, ximepa, ximstt, oldont + common /ximecm/ ximert + integer*2 st0001(6) + integer*2 st0002(5) + integer*2 st0003(12) + integer*2 st0004(8) + integer*2 st0005(12) + integer*2 st0006(21) + integer*2 st0007(10) + integer*2 st0008(8) + save + integer iyy + data st0001 / 37,115, 58, 37,115, 0/ + data st0002 /116,101,120,116, 0/ + data (st0003(iyy),iyy= 1, 8) / 99,111,110,110,101, 99,116, 32/ + data (st0003(iyy),iyy= 9,12) / 37,115, 0, 0/ + data st0004 /120,105,109,116,111,111,108, 0/ + data (st0005(iyy),iyy= 1, 8) /117,110,105,120, 58, 37,115, 58/ + data (st0005(iyy),iyy= 9,12) / 37,115, 0, 0/ + data (st0006(iyy),iyy= 1, 8) / 82,101, 99,111,110,110,101, 99/ + data (st0006(iyy),iyy= 9,16) /116,101,100, 32,111,110, 32, 39/ + data (st0006(iyy),iyy=17,21) / 37,115, 39, 10, 0/ + data (st0007(iyy),iyy= 1, 8) /114,101, 97,100,121, 32, 37,115/ + data (st0007(iyy),iyy= 9,10) / 0, 0/ + data st0008 /120,105,109,116,111,111,108, 0/ + data ximert /0/ + call smark (sp) + call salloc (buf, 1023 , 2) + call salloc (cmsg, 1023 , 2) + call salloc (dev, 255 , 2) + call aclrc (memc(buf), 1023 ) + call aclrc (memc(cmsg), 1023 ) + call aclrc (memc(dev), 255 ) + call aclrc (buffer, 2047) + fdin = 0 + fdout = 0 + nbuf = 0 + nr = 0 + nw = 0 + call sprinf (memc(dev), 255 , st0001) + call pargsr (device) + call pargsr (type) + if (.not.(streq (type, st0002))) goto 110 + mode = 1 + goto 111 +110 continue + mode = 2 +111 continue + call xerpsh + fdin = ndopen (memc(dev), 2) + if (.not.xerpop()) goto 120 + call sfree (sp) + ximcot = (-1) + goto 100 +120 continue + fdout = reopen (fdin, 2) + call sprinf (memc(cmsg), 1023 , st0003) + call pargsr (name) + msglen = xstrln(memc(cmsg)) + call ximmee (st0004, memc(cmsg)) + if (.not.(ximred (memc(buf), msglen) .eq. -2)) goto 130 + call sfree (sp) + ximcot = (-1) + goto 100 +130 continue + call xfcloe(fdout) + call xfcloe(fdin) + call sprinf (connet, 1023 , st0005) + call pargsr (memc(buf+8)) + call pargsr (type) + call xerpsh + fdin = ndopen (connet, 2) + if (.not.xerpop()) goto 140 + call sfree (sp) + ximcot = (-1) + goto 100 +140 continue + fdout = reopen (fdin, 2) + if (.not.(.true.)) goto 150 + call eprinf (st0006) + call pargsr (connet) +150 continue + call sprinf (memc(cmsg), 1023 , st0007) + call pargsr (name) + msglen = xstrln(memc(cmsg)) + call ximmee (st0008, memc(cmsg)) + call onerrr (ximonr) + call sfree (sp) + ximcot = (0) + goto 100 +100 return + end + subroutine ximdit (sendqt) + integer sendqt + integer fdin + integer fdout + integer mode + integer nbuf + integer nr + integer nw + integer*2 buffer(2047+1) + common /ximfd/ fdin, fdout, mode, nbuf, buffer, nr, nw + integer*2 st0001(8) + integer*2 st0002(5) + save + data st0001 /120,105,109,116,111,111,108, 0/ + data st0002 /113,117,105,116, 0/ + if (.not.(sendqt .eq. 1)) goto 110 + call ximmee (st0001, st0002) +110 continue + call xffluh(fdout) + call xfcloe(fdin) + call xfcloe(fdout) + fdin = 0 + fdout = 0 +100 return + end + subroutine ximmee (object, messae) + integer*2 object(*) + integer*2 messae(*) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer sp + integer msgbuf + integer msglen + integer olen + integer mlen + integer ip + integer xstrln + logical streq + integer*2 st0001(8) + integer*2 st0002(6) + integer*2 st0003(4) + integer*2 st0004(4) + save + data st0001 /120,105,109,116,111,111,108, 0/ + data st0002 /115,101,110,100, 32, 0/ + data st0003 / 32,123, 32, 0/ + data st0004 / 32,125, 0, 0/ + olen = xstrln(object) + mlen = xstrln(messae) + msglen = olen + mlen + 20 + call smark (sp) + call salloc (msgbuf, msglen, 2) + call aclrc (memc(msgbuf), msglen) + if (.not.(streq (object, st0001))) goto 110 + call xstrcy(messae, memc(msgbuf), msglen) + goto 111 +110 continue + ip = 0 + call amovc (st0002, memc(msgbuf+ip), 5) + ip = ip + 5 + call amovc (object, memc(msgbuf+ip), olen) + ip = ip + olen + call amovc (st0003, memc(msgbuf+ip), 3) + ip = ip + 3 + call amovc (messae, memc(msgbuf+ip), mlen) + ip = ip + mlen + call amovc (st0004, memc(msgbuf+ip), 2) + ip = ip + 3 +111 continue + msglen = xstrln(memc(msgbuf)) + call ximwre (memc(msgbuf), msglen) + call sfree (sp) +100 return + end + subroutine ximalt (text, ok, cancel) + integer*2 text(*) + integer*2 ok(*) + integer*2 cancel(*) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer sp + integer msg + integer*2 st0001(15) + integer*2 st0002(6) + save + integer iyy + data (st0001(iyy),iyy= 1, 8) /123, 37,115,125, 32,123, 37,115/ + data (st0001(iyy),iyy= 9,15) /125, 32,123, 37,115,125, 0/ + data st0002 / 97,108,101,114,116, 0/ + call smark (sp) + call salloc (msg, 1023 , 2) + call sprinf (memc(msg), 1023 , st0001) + call pargsr (text) + call pargsr (ok) + call pargsr (cancel) + call ximmee (st0002, memc(msg)) + call sfree (sp) +100 return + end + subroutine ximwre (messae, len) + integer len + integer*2 messae(*) + integer nleft + integer n + integer ip + integer*2 msgbuf(2047+1) + integer xstrln + integer fdin + integer fdout + integer mode + integer nbuf + integer nr + integer nw + integer*2 buffer(2047+1) + common /ximfd/ fdin, fdout, mode, nbuf, buffer, nr, nw + logical xerflg + common /xercom/ xerflg + integer*2 st0001(42) + save + integer iyy + data (st0001(iyy),iyy= 1, 8) /120,105,109, 95,119,114,105,116/ + data (st0001(iyy),iyy= 9,16) /101, 58, 32, 39, 37, 46, 52, 53/ + data (st0001(iyy),iyy=17,24) /115, 39, 32,108,101,110, 61, 37/ + data (st0001(iyy),iyy=25,32) /100, 32,109,111,100,101, 61, 37/ + data (st0001(iyy),iyy=33,40) /100, 32,116,111,116, 61, 37,100/ + data (st0001(iyy),iyy=41,42) / 10, 0/ + len = xstrln(messae) + 1 + messae(len) = 0 + if (.not.(mod(len,2) .eq. 1)) goto 110 + len = len + 1 + messae(len) = 0 +110 continue + ip = 1 + nleft = len +120 if (.not.(nleft .gt. 0)) goto 121 + n = min (nleft, 2047) + call amovc (messae(ip), msgbuf, n) + if (.not.(mode .eq. 2)) goto 130 + call achtcb (msgbuf, msgbuf, n) + call xfwrie(fdout, msgbuf, n / 2 ) + if (xerflg) goto 100 + goto 131 +130 continue + call xfwrie(fdout, msgbuf, n) + if (xerflg) goto 100 +131 continue + ip = ip + n + nleft = nleft - n + goto 120 +121 continue + nw = nw + len + call xffluh(fdout) + if (xerflg) goto 100 + if (.not.(.true.)) goto 140 + call eprinf (st0001) + call pargsr (messae) + call pargi (len) + call pargi (mode) + call pargi (nw) +140 continue +100 return + end + integer function ximred (messae, len) + integer len + integer*2 messae(*) + integer i + integer n + integer nleft + integer xfread + integer fdin + integer fdout + integer mode + integer nbuf + integer nr + integer nw + integer*2 buffer(2047+1) + integer ximepa + integer ximstt + integer oldont + integer ximfd + integer ximjmp(64 ) + logical xerpop + logical xerflg + common /xercom/ xerflg + common /ximfd/ fdin, fdout, mode, nbuf, buffer, nr, nw + common /ximcom/ ximfd, ximjmp, ximepa, ximstt, oldont + integer*2 st0001(42) + integer*2 st0002(40) + save + integer iyy + data (st0001(iyy),iyy= 1, 8) /120,105,109, 95,114,101, 97,100/ + data (st0001(iyy),iyy= 9,16) / 58, 32,116,111,116, 61, 37,100/ + data (st0001(iyy),iyy=17,24) / 32,108,101,110, 61, 37,100, 47/ + data (st0001(iyy),iyy=25,32) / 37,100, 32,109,115,103, 61, 39/ + data (st0001(iyy),iyy=33,40) / 37, 51, 48, 46, 51, 48,115, 39/ + data (st0001(iyy),iyy=41,42) / 10, 0/ + data (st0002(iyy),iyy= 1, 8) /120,105,109, 95,114,101, 97,100/ + data (st0002(iyy),iyy= 9,16) / 58, 32,110, 98,117,102, 61, 37/ + data (st0002(iyy),iyy=17,24) /100, 32,110,108,101,102,116, 61/ + data (st0002(iyy),iyy=25,32) / 37,100, 32, 98,117,102,102,101/ + data (st0002(iyy),iyy=33,40) /114, 61, 39, 37,115, 39, 10, 0/ + if (.not.(nbuf .eq. 0)) goto 110 + call aclrc (buffer, 2047) + nbuf = 0 + call xerpsh + n = xfread(fdin, messae, 2047) + if (xerflg) goto 122 + if (.not.(n .lt. 0)) goto 130 + ximred = (-2) + goto 100 +130 continue +122 if (.not.xerpop()) goto 120 + call xerret() + call zdojmp (ximjmp, 504 ) +120 continue + if (.not.(mode .eq. 2)) goto 140 + len = n * 2 + call achtbc (messae, messae, len) + goto 141 +140 continue + len = n +141 continue + call amovc (messae, buffer, len) + if (.not.(buffer(len) .eq. 0 .and. buffer(len-1) .eq. 0)) + * goto 150 + nbuf = len + goto 151 +150 continue + nbuf = len + 1 +151 continue + buffer(nbuf) = -2 +110 continue + i=1 +160 if (.not.(buffer(i) .ne. 0 .and. buffer(i) .ne. -2 .and. i .le. + * nbuf)) goto 162 + messae(i) = buffer(i) +161 i=i+1 + goto 160 +162 continue + messae(i) = 0 + len = i + nleft = nbuf - i + nr = nr + len + if (.not.(buffer(i) .eq. 0 .and. buffer(i+1) .eq. -2)) goto 170 + if (.not.(i .gt. 1 .and. nleft .gt. 1)) goto 180 + call amovc (buffer(i+1), buffer, nleft) +180 continue + nbuf = 0 + goto 171 +170 continue + if (.not.(nleft .gt. 0)) goto 190 + call amovc (buffer(i+1), buffer, nleft) +190 continue + nbuf = nleft +171 continue + if (.not.(.true.)) goto 200 + call eprinf (st0001) + call pargi(nr) + call pargi (len) + call pargsr(messae) + call eprinf (st0002) + call pargi (nbuf) + call pargi(nleft) + call pargsr(buffer) +200 continue + ximred = (nleft) + goto 100 +100 return + end + integer function ximinr () + external ximzxn + integer ximepa + integer ximstt + integer oldont + integer ximfd + integer ximjmp(64 ) + common /ximcom/ ximfd, ximjmp, ximepa, ximstt, oldont + save + call zlocpr (ximzxn, ximepa) + call xwhen (503 , ximepa, oldont) + call zsvjmp (ximjmp, ximstt) + if (.not.(ximstt .eq. 0)) goto 110 + ximinr = (0) + goto 100 +110 continue + ximinr = (-1) + goto 100 +111 continue +100 return + end + subroutine ximzxn (vex, nexthr) + integer vex + integer nexthr + integer ximepa + integer ximstt + integer oldont + integer ximfd + integer ximjmp(64 ) + common /ximcom/ ximfd, ximjmp, ximepa, ximstt, oldont + save + call ximdit (1) + call xerret() + call zdojmp (ximjmp, vex) +100 return + end + subroutine ximonr (status) + integer status + integer ximert + integer code + integer*2 buf(1023 +1) + integer*2 errmsg(1023 +1) + integer errget + integer ximepa + integer ximstt + integer oldont + integer ximfd + integer ximjmp(64 ) + common /ximecm/ ximert + common /ximcom/ ximfd, ximjmp, ximepa, ximstt, oldont + integer*2 st0001(25) + save + integer iyy + data (st0001(iyy),iyy= 1, 8) / 73, 83, 77, 32, 69,114,114,111/ + data (st0001(iyy),iyy= 9,16) /114, 44, 32, 99,111,100,101, 32/ + data (st0001(iyy),iyy=17,24) / 37,100, 58, 10, 96, 37,115, 39/ + data (st0001(iyy),iyy=25,25) / 0/ + if (.not.(status .ne. 0)) goto 110 + code = errget (errmsg, 1023 ) + call sprinf (buf, 1023 , st0001) + call pargi (status) + call pargsr (errmsg) + call ximalt (buf, 0, 0) + call ximdit (1) +110 continue +100 return + end +c ximonr xim_onerror +c sprinf sprintf +c onerrr onerror +c ximstt ximstat +c ximmee xim_message +c messae message +c ximcot xim_connect +c connet connect +c ximinr xim_intrhandler +c ximalt xim_alert +c oldont old_onint +c ximecm ximecom +c ximred xim_read +c ximjmp xim_jmp +c sendqt send_quit +c eprinf eprintf +c nexthr next_handler +c ximzxn xim_zxwhen +c xerret xer_reset +c ximdit xim_disconnect +c ximwre xim_write +c pargsr pargstr +c ximert xim_errstat diff --git a/vendor/x11iraf/ximtool/clients.old/lib/ximtool.x b/vendor/x11iraf/ximtool/clients.old/lib/ximtool.x new file mode 100644 index 00000000..dff5869c --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/ximtool.x @@ -0,0 +1,459 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include <config.h> +include <mach.h> +include <xwhen.h> + + +# XIMTOOL.X -- Interface routines for client programs to connect to +# XImtool on the message bus. +# +# status = xim_connect (device, name, mode) +# status = xim_file_connect (infile, outfile, name) +# xim_disconnect (send_quit) +# xim_message (object, message) +# xim_alert (text, ok_action, cancel_action) +# +# xim_write (message, len) +# nremain = xim_read (message, len) +# +# Client programs should install an exception handler to first disconnect +# from the device before shutting down. The procedure xim_zxwhen() is +# provided for this purpose. + + +define XIM_DBG TRUE + +define SZ_MESSAGE 2047 + +define XIM_TEXT 1 +define XIM_BINARY 2 + + +# XIM_CONNECT -- Negotiate a connection on the named device. Once +# established we can begin sending and reading messages from the server. + +int procedure xim_connect (device, name, type) + +char device[ARB] #I socket to connect on +char name[ARB] #I module name +char type[ARB] #I requested connection mode + +pointer sp, cmsg, dev, buf +int msglen +char connect[SZ_FNAME] + +int ndopen(), reopen(), strlen() +int xim_read() +bool streq() + +extern xim_onerror() + +# I/O common. +int fdin, fdout, mode, nbuf, nr, nw +char buffer[SZ_MESSAGE] +common /ximfd/ fdin, fdout, mode, nbuf, buffer, nr, nw + +# Interrupt handler variables common. +int ximepa, ximstat, old_onint, xim_fd, xim_jmp[LEN_JUMPBUF] +common /ximcom/ xim_fd, xim_jmp, ximepa, ximstat, old_onint + +# Exception handler variables common. +int xim_errstat +data xim_errstat /OK/ +common /ximecom/ xim_errstat + +begin + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + call salloc (cmsg, SZ_LINE, TY_CHAR) + call salloc (dev, SZ_FNAME, TY_CHAR) + + # Initialize. + call aclrc (Memc[buf], SZ_LINE) + call aclrc (Memc[cmsg], SZ_LINE) + call aclrc (Memc[dev], SZ_FNAME) + call aclrc (buffer, SZ_MESSAGE) + fdin = NULL + fdout = NULL + nbuf = 0 + nr = 0 + nw = 0 + + # Generate the device name. We assume the call was made with either + # a "unix:" or "inet:" prefix, so just append the type and set the + # mode. + + call sprintf (Memc[dev], SZ_FNAME, "%s:%s") + call pargstr (device) + call pargstr (type) + if (streq (type, "text")) + mode = XIM_TEXT + else + mode = XIM_BINARY + + # Open the initial connection + iferr (fdin = ndopen (Memc[dev], READ_WRITE)) { + call sfree (sp) + return (ERR) + } + fdout = reopen (fdin, READ_WRITE) + + # Send the connect request. + call sprintf (Memc[cmsg], SZ_LINE, "connect %s\0") + call pargstr (name) + msglen = strlen (Memc[cmsg]) + call xim_message ("ximtool", Memc[cmsg]) + + # Read the acknowledgement. + if (xim_read (Memc[buf], msglen) == EOF) { + call sfree (sp) + return (ERR) + } + + # Close the original socket. + call close (fdout) + call close (fdin) + + # Get the new device name. + call sprintf (connect, SZ_LINE, "unix:%s:%s\0") + call pargstr (Memc[buf+8]) + call pargstr (type) + + # Open the new channel. + iferr (fdin = ndopen (connect, READ_WRITE)) { + call sfree (sp) + return (ERR) + } + fdout = reopen (fdin, READ_WRITE) + + if (XIM_DBG) { + call eprintf ("Reconnected on '%s'\n"); call pargstr (connect) + } + + # Tell the server we're ready to begin. + call sprintf (Memc[cmsg], SZ_LINE, "ready %s\0") + call pargstr (name) + msglen = strlen (Memc[cmsg]) + call xim_message ("ximtool", Memc[cmsg]) + + + # Post the xim_onerror procedure to be executed upon process shutdown + # to issue a warning to the server in case we don't close normally. + + call onerror (xim_onerror) + + call sfree (sp) + return (OK) +end + + +# XIM_DISCONNECT -- Disconnect from the currect channel. + +procedure xim_disconnect (send_quit) + +int send_quit + +# I/O common. +int fdin, fdout, mode, nbuf, nr, nw +char buffer[SZ_MESSAGE] +common /ximfd/ fdin, fdout, mode, nbuf, buffer, nr, nw + +begin + # Send a QUIT message to the server so we shut down the connection. + if (send_quit == YES) + call xim_message ("ximtool", "quit") + + call flush (fdout) # Close the socket connection. + call close (fdin) + call close (fdout) + fdin = NULL + fdout = NULL +end + + +# XIM_MESSAGE -- Send a message to an XImtool named object. If the object +# is 'ximtool' then just pass the message directly without formatting it. + +procedure xim_message (object, message) + +char object[ARB] #I object name +char message[ARB] #I message to send + +pointer sp, msgbuf +int msglen, olen, mlen, ip + +int strlen() +bool streq() + +begin + # Get the message length plus some extra for the braces and padding. + olen = strlen (object) + mlen = strlen (message) + msglen = olen + mlen + 20 + + # Allocate and clear the message buffer. + call smark (sp) + call salloc (msgbuf, msglen, TY_CHAR) + call aclrc (Memc[msgbuf], msglen) + + if (streq (object, "ximtool")) { + # Just send the message. + call strcpy (message, Memc[msgbuf], msglen) + } else { + # Format the message. We can't use a sprintf here since the + # message may be bigger than that allowed by a pargstr(). + ip = 0 + call amovc ("send ", Memc[msgbuf+ip], 5) ; ip = ip + 5 + call amovc (object, Memc[msgbuf+ip], olen) ; ip = ip + olen + call amovc (" { ", Memc[msgbuf+ip], 3) ; ip = ip + 3 + call amovc (message, Memc[msgbuf+ip], mlen) ; ip = ip + mlen + call amovc (" }\0", Memc[msgbuf+ip], 2) ; ip = ip + 3 + } + msglen = strlen (Memc[msgbuf]) + + # Now send the message. The write routine does the strpak(). + call xim_write (Memc[msgbuf], msglen) + + call sfree (sp) +end + + +# XIM_ALERT -- Send an alert message to XImtool. + +procedure xim_alert (text, ok, cancel) + +char text[ARB] #I warning text +char ok[ARB] #i client OK message +char cancel[ARB] #i client CANCEL message + +pointer sp, msg + +begin + call smark (sp) + call salloc (msg, SZ_LINE, TY_CHAR) + + call sprintf (Memc[msg], SZ_LINE, "{%s} {%s} {%s}") + call pargstr (text) + call pargstr (ok) + call pargstr (cancel) + + call xim_message ("alert", Memc[msg]) + + call sfree (sp) +end + + +# XIM_WRITE -- Low-level write of a message to the socket. Writes exactly +# len bytes to the stream. + +procedure xim_write (message, len) + +char message[ARB] #I message to send +int len #I length of message + +int nleft, n, ip +char msgbuf[SZ_MESSAGE] +int strlen() + +# I/O common. +int fdin, fdout, mode, nbuf, nr, nw +char buffer[SZ_MESSAGE] +common /ximfd/ fdin, fdout, mode, nbuf, buffer, nr, nw + +errchk write, flush + +begin + # Pad message with a NULL to terminate it. + len = strlen (message) + 1 + message[len] = '\0' + + if (mod(len,2) == 1) { + len = len + 1 + message[len] = '\0' + } + + ip = 1 + nleft = len + while (nleft > 0) { + n = min (nleft, SZ_MESSAGE) + call amovc (message[ip], msgbuf, n) + if (mode == XIM_BINARY) { + call achtcb (msgbuf, msgbuf, n) + call write (fdout, msgbuf, n / SZB_CHAR) + } else + call write (fdout, msgbuf, n) + + ip = ip + n + nleft = nleft - n + } + nw = nw + len + call flush (fdout) + + if (XIM_DBG) { + call eprintf ("xim_write: '%.45s' len=%d mode=%d tot=%d\n") + call pargstr (message);call pargi (len) + call pargi (mode); call pargi (nw) + } +end + + +# XIM_READ -- Low-level read from the socket. + +int procedure xim_read (message, len) + +char message[ARB] #O message read +int len #O length of message + +int i, n, nleft, read() + +# I/O common. +int fdin, fdout, mode, nbuf, nr, nw +char buffer[SZ_MESSAGE] +common /ximfd/ fdin, fdout, mode, nbuf, buffer, nr, nw + +# Interrupt handler variables common. +int ximepa, ximstat, old_onint, xim_fd, xim_jmp[LEN_JUMPBUF] +common /ximcom/ xim_fd, xim_jmp, ximepa, ximstat, old_onint + +errchk read + +begin + # No data left in the buffer so read from the socket + if (nbuf == 0) { + call aclrc (buffer, SZ_MESSAGE) + nbuf = 0 + + iferr { + n = read (fdin, message, SZ_MESSAGE) + if (n < 0) + return (EOF) + } then { + call xer_reset() + call zdojmp (xim_jmp, X_IPC) + } + + if (mode == XIM_BINARY) { + len = n * SZB_CHAR + call achtbc (message, message, len) + } else + len = n + + # Save the data read to a local buffer. Remove any extra + # EOS padding and append an EOF on the string. + call amovc (message, buffer, len) + if (buffer[len] == EOS && buffer[len-1] == EOS) + nbuf = len + else + nbuf = len + 1 + buffer[nbuf] = EOF + } + + for (i=1; buffer[i] != EOS && buffer[i] != EOF && i <= nbuf; i=i+1) + message[i] = buffer[i] + message[i] = '\0' + len = i # length of the current message + nleft = nbuf - i # nchars left in the buffer + nr = nr + len + + if (buffer[i] == EOS && buffer[i+1] == EOF) { + # That was the last message, force a new read next time we're + # called. + if (i > 1 && nleft > 1) + call amovc (buffer[i+1], buffer, nleft) + nbuf = 0 + } else { + # More of the message is left in the buffer. + if (nleft > 0) + call amovc (buffer[i+1], buffer, nleft) + nbuf = nleft + } + + if (XIM_DBG) { + call eprintf ("xim_read: tot=%d len=%d/%d msg='%30.30s'\n") + call pargi(nr); call pargi (len) + call pargstr(message) + call eprintf ("xim_read: nbuf=%d nleft=%d buffer='%s'\n") + call pargi (nbuf); call pargi(nleft); call pargstr(buffer) + } + + #return (len) + return (nleft) +end + + +# XIM_INTRHANDLER -- User-callable interrupt handler so the ISM client code +# doesn't need to know about our internals. + +int procedure xim_intrhandler() + +extern xim_zxwhen() + +# Interrupt handler variables common. +int ximepa, ximstat, old_onint, xim_fd, xim_jmp[LEN_JUMPBUF] +common /ximcom/ xim_fd, xim_jmp, ximepa, ximstat, old_onint + +begin + call zlocpr (xim_zxwhen, ximepa) + call xwhen (X_INT, ximepa, old_onint) + call zsvjmp (xim_jmp, ximstat) + + if (ximstat == OK) + return (OK) + else + return (ERR) +end + + +# XIM_ZXWHEN -- Interrupt handler for the Ximtool client task. Branches back +# to ZSVJMP in the user routine to permit shutdown without an error message +# after first disconnecting from the socket. + +procedure xim_zxwhen (vex, next_handler) + +int vex # virtual exception +int next_handler # not used + +# Interrupt handler variables common. +int ximepa, ximstat, old_onint, xim_fd, xim_jmp[LEN_JUMPBUF] +common /ximcom/ xim_fd, xim_jmp, ximepa, ximstat, old_onint + +begin + call xim_disconnect (YES) + call xer_reset() + call zdojmp (xim_jmp, vex) +end + + +# XIM_ONERROR -- Error exit handler for the interface. If this is a normal exit +# the shut down quietly, otherwise notify the server. + +procedure xim_onerror (status) + +int status #i not used (req. for ONEXIT) + +# Exception handler variables common. +int xim_errstat +common /ximecom/ xim_errstat + +int code +char buf[SZ_LINE], errmsg[SZ_LINE] + +int errget() + +# Interrupt handler variables common. +int ximepa, ximstat, old_onint, xim_fd, xim_jmp[LEN_JUMPBUF] +common /ximcom/ xim_fd, xim_jmp, ximepa, ximstat, old_onint + +begin + if (status != OK) { + code = errget (errmsg, SZ_LINE) + call sprintf (buf, SZ_LINE, "ISM Error, code %d:\n`%s\'") + call pargi (status) + call pargstr (errmsg) + + call xim_alert (buf, NULL, NULL) + call xim_disconnect (YES) + } +end diff --git a/vendor/x11iraf/ximtool/clients.old/lib/zfiond.c b/vendor/x11iraf/ximtool/clients.old/lib/zfiond.c new file mode 100644 index 00000000..1ae65048 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/zfiond.c @@ -0,0 +1,723 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include <sys/types.h> +#include <sys/stat.h> +#include <sys/file.h> +#include <sys/socket.h> +#include <netinet/in.h> +#include <sys/un.h> +#include <netdb.h> +#include <fcntl.h> + +#ifdef LINUX +#include <sys/time.h> +#endif + +#include <errno.h> +#include <stdio.h> + +#define import_kernel +#define import_knames +#define import_zfstat +#define import_spp +#include <iraf.h> + +/* + * ZFIOND -- This driver provides a FIO-compatible interface to network or + * IPC streaming devices such as Berkeley sockets, FIFOs, and the like. + * Any connection-oriented stream type network interface can be supported. + * + * The type of connection desired is determined at device open time by the + * "filename" and file access mode arguments. The syntax for the filename + * argument is as follows: + * + * <domain> : <address> [ : <flag ] [ : flag...] + * + * where <domain> is one of "inet" (internet tcp/ip socket), "unix" (unix + * domain socket) or "fifo" (named pipe). The form of the address depends + * upon the domain, as illustrated in the examples below. + * + * inet:5187 Server connection to port 5187 on the local + * host. For a client, a connection to the + * given port on the local host. + * + * inet:5187:foo.bar.edu Client connection to port 5187 on internet + * host foo.bar.edu. The dotted form of address + * may also be used. + * + * unix:/tmp/.IMT212 Unix domain socket with the given pathname + * IPC method, local host only. + * + * fifo:/dev/imt1i:/dev/imt1o FIFO or named pipe with the given pathname. + * IPC method, local host only. Two pathnames + * are required, one for input and one for + * output, since FIFOs are not bidirectional. + * For a client the first fifo listed will be + * the client's input fifo; for a server the + * first fifo will be the server's output fifo. + * This allows the same address to be used for + * both the client and the server, as for the + * other domains. + * + * The address field may contain up to two "%d" fields. If present, the + * user's UID will be substituted (e.g. "unix:/tmp/.IMT%d"). + * + * The only protocol flags currently supported are "text" and "binary". + * If "text" is specified the datastream is assumed to consist only of byte + * packed ascii text and is automatically converted by the driver to and + * from SPP chars during i/o. The default is binary i/o (no conversions). + * + * Client connections normally use mode READ_WRITE, although READ_ONLY and + * WRITE_ONLY are permitted. APPEND is the same as WRITE_ONLY. A server + * connection is indicated by the mode NEW_FILE. The endpoints of the server + * connection will be created if necessary. A client connection will timeout + * if no server responds. + * + * An INET or UNIX domain server connection will block indefinitely until a + * client connects. Since connections are synchronous only a single client + * can be supported. The server sees an EOF on the input stream when the + * client disconnects. + * + * FIFO domain connection are slightly different. When the server opens a FIFO + * connection the open returns immediately. When the server reads from the + * input fifo the server will block until some data is written to the fifo by a + * client. The server connection will remain open over multiple client + * connections until it is closed by the server. This is done to avoid a race + * condition that could otherwise occur at open time, with both the client and + * the server blocked waiting for an open on the opposite stream. + */ + +#define SZ_NAME 256 +#define SZ_OBUF 4096 +#define MAXCONN 5 +#define MAXSEL 32 + +#define INET 1 +#define UNIX 2 +#define FIFO 3 + +#define F_SERVER 00001 +#define F_DEL1 00002 +#define F_DEL2 00004 +#define F_TEXT 00010 + +/* Network portal descriptor. */ +struct portal { + int domain; + int flags; + int datain; + int dataout; + int keepalive; + char path1[SZ_NAME]; + char path2[SZ_NAME]; +}; + +#define get_desc(fd) ((struct portal *)zfd[fd].fp) +#define set_desc(fd,np) zfd[fd].fp = (FILE *)np +#define min(a,b) (((a)<(b))?(a):(b)) + +extern int errno; +static int getstr(); + + +/* ZOPNND -- Open a network device. + */ +ZOPNND (pk_osfn, mode, chan) +PKCHAR *pk_osfn; /* UNIX name of file */ +XINT *mode; /* file access mode */ +XINT *chan; /* file number (output) */ +{ + register int fd; + register struct portal *np; + unsigned short host_port; + unsigned long host_addr; + char osfn[SZ_NAME*2]; + char flag[SZ_NAME]; + char *ip; + + /* Get network device descriptor. */ + if (!(np = (struct portal *) calloc (1, sizeof(struct portal)))) { + *chan = XERR; + return; + } + + /* Expand any %d fields in the network address to the UID. */ + sprintf (osfn, (char *)pk_osfn, getuid(), getuid()); + + /* Parse the network filename to determine the domain type and + * network address. + */ + if (strncmp (osfn, "inet:", 5) == 0) { + /* Internet connection. + */ + char port_str[SZ_NAME]; + char host_str[SZ_NAME]; + unsigned short port; + struct servent *sv; + struct hostent *hp; + + /* Get port number. This may be specified either as a service + * name or as a decimal port number. + */ + ip = osfn + 5; + if (getstr (&ip, port_str, SZ_NAME) <= 0) + goto err; + if (isdigit (port_str[0])) { + port = atoi (port_str); + host_port = htons (port); + } else if (sv = getservbyname(port_str,"tcp")) { + host_port = sv->s_port; + } else + goto err; + + /* Get host address. This may be specified either has a host + * name or as an Internet address in dot notation. If no host + * name is specified default to the local host. + */ + if (getstr (&ip, host_str, SZ_NAME) <= 0) + strcpy (host_str, "localhost"); + if (isdigit (host_str[0])) { + host_addr = inet_addr (host_str); + if ((int)host_addr == -1) + goto err; + } else if (hp = gethostbyname(host_str)) { + bcopy (hp->h_addr, (char *)&host_addr, sizeof(host_addr)); + } else + goto err; + + np->domain = INET; + + } else if (strncmp (osfn, "unix:", 5) == 0) { + /* Unix domain socket connection. + */ + ip = osfn + 5; + if (!getstr (&ip, np->path1, SZ_NAME)) + goto err; + np->domain = UNIX; + + } else if (strncmp (osfn, "fifo:", 5) == 0) { + /* FIFO (named pipe) connection. + */ + ip = osfn + 5; + if (*mode == NEW_FILE) { + /* Server. */ + if (!getstr (&ip, np->path2, SZ_NAME)) + goto err; + if (!getstr (&ip, np->path1, SZ_NAME)) + goto err; + } else { + /* Client. */ + if (!getstr (&ip, np->path1, SZ_NAME)) + goto err; + if (!getstr (&ip, np->path2, SZ_NAME)) + goto err; + } + np->domain = FIFO; + + } else + goto err; + + /* Process any optional protocol flags. + */ + while (getstr (&ip, flag, SZ_NAME) > 0) { + /* Get content type (text or binary). If the stream will be used + * only for byte-packed character data the content type can be + * specified as "text" and data will be automatically packed and + * unpacked during i/o. + */ + if (strcmp (flag, "text") == 0) + np->flags |= F_TEXT; + if (strcmp (flag, "binary") == 0) + np->flags &= ~F_TEXT; + } + + /* Open the network connection. + */ + switch (*mode) { + case READ_ONLY: + /* Client side read only FIFO connection. */ + if (np->domain == FIFO) { + if ((fd = open (np->path1, O_RDONLY|O_NDELAY)) != ERR) + fcntl (fd, F_SETFL, O_RDONLY); + np->datain = fd; + np->dataout = -1; + break; + } + /* fall through */ + + case WRITE_ONLY: + case APPEND: + /* Client side write only FIFO connection. */ + if (np->domain == FIFO) { + if ((fd = open (np->path2, O_WRONLY|O_NDELAY)) != ERR) + fcntl (fd, F_SETFL, O_WRONLY); + np->datain = -1; + np->dataout = fd; + break; + } + /* fall through */ + + case READ_WRITE: + if (np->domain == INET) { + /* Client side Internet domain connection. */ + struct sockaddr_in sockaddr; + + /* Get socket. */ + if ((fd = socket (AF_INET, SOCK_STREAM, 0)) < 0) + goto err; + + /* Compose network address. */ + bzero ((char *)&sockaddr, sizeof(sockaddr)); + sockaddr.sin_family = AF_INET; + sockaddr.sin_port = host_port; + bcopy ((char *)&host_addr, (char *)&sockaddr.sin_addr, + sizeof(host_addr)); + + /* Connect to server. */ + if (fd >= MAXOFILES || connect (fd, + (struct sockaddr *)&sockaddr, sizeof(sockaddr)) < 0) { + close (fd); + fd = ERR; + } else { + np->datain = fd; + np->dataout = fd; + } + + } else if (np->domain == UNIX) { + /* Client side Unix domain socket connection. */ + struct sockaddr_un sockaddr; + + /* Get socket. */ + if ((fd = socket (AF_UNIX, SOCK_STREAM, 0)) < 0) + goto err; + + /* Compose network address. */ + bzero ((char *)&sockaddr, sizeof(sockaddr)); + sockaddr.sun_family = AF_UNIX; + strncpy (sockaddr.sun_path, + np->path1, sizeof(sockaddr.sun_path)); + + /* Connect to server. */ + if (fd >= MAXOFILES || connect (fd, + (struct sockaddr *)&sockaddr, sizeof(sockaddr)) < 0) { + close (fd); + fd = ERR; + } else { + np->datain = fd; + np->dataout = fd; + } + + } else if (np->domain == FIFO) { + /* Client side FIFO connection. */ + int fd1, fd2; + + /* Open the fifos. */ + if ((fd1 = open (np->path1, O_RDONLY|O_NDELAY)) != ERR) + fcntl (fd1, F_SETFL, O_RDONLY); + if ((fd2 = open (np->path2, O_WRONLY|O_NDELAY)) != ERR) + fcntl (fd2, F_SETFL, O_WRONLY); + + /* Clean up if there is an error. */ + if (fd1 < 0 || fd1 > MAXOFILES || fd2 < 0 || fd2 > MAXOFILES) { + if (fd1 > 0) + close (fd1); + if (fd2 > 0) + close (fd2); + fd = ERR; + } else { + np->datain = fd1; + np->dataout = fd2; + fd = fd1; + } + } else + goto err; + break; + + case NEW_FILE: + /* Connect to a client. */ + np->flags |= F_SERVER; + + if (np->domain == INET) { + /* Server side Internet domain connection. */ + struct sockaddr_in sockaddr; + int s, reuse=1; + + /* Get socket. */ + if ((s = socket (AF_INET, SOCK_STREAM, 0)) < 0) + goto err; + + /* Bind server port to socket. */ + bzero ((char *)&sockaddr, sizeof(sockaddr)); + sockaddr.sin_family = AF_INET; + sockaddr.sin_port = host_port; + sockaddr.sin_addr.s_addr = htonl(INADDR_ANY); + + if (setsockopt(s, SOL_SOCKET, SO_REUSEADDR, (char *)&reuse, + sizeof(reuse)) < 0) { + close (s); + goto err; + } + + if (bind (s, + (struct sockaddr *)&sockaddr, sizeof(sockaddr)) < 0) { + close (s); + goto err; + } + + /* Wait for client to connect. */ + if (listen (s, MAXCONN) < 0) { + close (s); + goto err; + } + if ((fd = accept (s, (struct sockaddr *)0, (int *)0)) < 0) { + close (s); + goto err; + } else + close (s); + + np->datain = fd; + np->dataout = fd; + + } else if (np->domain == UNIX) { + /* Server side Unix domain connection. */ + struct sockaddr_un sockaddr; + int addrlen, s; + + /* Get socket. */ + if ((s = socket (AF_UNIX, SOCK_STREAM, 0)) < 0) + goto err; + + /* Bind server port to socket. */ + bzero ((char *)&sockaddr, sizeof(sockaddr)); + sockaddr.sun_family = AF_UNIX; + strncpy (sockaddr.sun_path,np->path1,sizeof(sockaddr.sun_path)); + addrlen = sizeof(sockaddr) - sizeof(sockaddr.sun_path) + + strlen(np->path1); + + unlink (np->path1); + if (bind (s, (struct sockaddr *)&sockaddr, addrlen) < 0) { + close (s); + goto err; + } + + /* Wait for client to connect. */ + if (listen (s, MAXCONN) < 0) { + close (s); + goto err; + } + if ((fd = accept (s, (struct sockaddr *)0, (int *)0)) < 0) { + close (s); + goto err; + } else + close (s); + + np->datain = fd; + np->dataout = fd; + np->flags |= F_DEL1; + + } else if (np->domain == FIFO) { + /* Server side FIFO connection. */ + int fd1, fd2, keepalive; + + /* Create fifos if necessary. */ + if (access (np->path1, 0) < 0) { + if (mknod (np->path1, 010660, 0) < 0) + goto err; + else + np->flags |= F_DEL1; + } + if (access (np->path2, 0) < 0) { + if (mknod (np->path2, 010660, 0) < 0) { + unlink (np->path1); + goto err; + } else + np->flags |= F_DEL2; + } + + /* Open the output fifo (which is the client's input fifo). + * We have to open it ourselves first as a client to get + * around the fifo open-no-client error. + */ + if ((fd1 = open (np->path2, O_RDONLY|O_NDELAY)) != -1) { + if ((fd2 = open (np->path2, O_WRONLY|O_NDELAY)) != -1) + fcntl (fd2, F_SETFL, O_WRONLY); + close (fd1); + } + + /* Open the input fifo. */ + if ((fd1 = open (np->path1, O_RDONLY|O_NDELAY)) == -1) + fprintf (stderr, "Warning: cannot open %s\n", np->path1); + else { + /* Clear O_NDELAY for reading. */ + fcntl (fd1, F_SETFL, O_RDONLY); + + /* Open the client's output fifo as a pseudo-client to + * make it appear that a client is connected. + */ + keepalive = open (np->path1, O_WRONLY); + } + + /* Clean up if there is an error. */ + if (fd1 < 0 || fd1 > MAXOFILES || fd2 < 0 || fd2 > MAXOFILES) { + if (fd1 > 0) { + close (fd1); + close (keepalive); + } + if (fd2 > 0) + close (fd2); + fd = ERR; + } else { + np->datain = fd1; + np->dataout = fd2; + np->keepalive = keepalive; + fd = fd1; + } + + } else + goto err; + break; + + default: + fd = ERR; + } + + /* Initialize the kernel file descriptor. Seeks are illegal for a + * network device; network devices are "streaming" files (blksize=1) + * which can only be accessed sequentially. + */ + if ((*chan = fd) == ERR) { +err: free (np); + *chan = XERR; + } else if (fd >= MAXOFILES) { + free (np); + close (fd); + *chan = XERR; + } else { + zfd[fd].fp = NULL; + zfd[fd].fpos = 0L; + zfd[fd].nbytes = 0; + zfd[fd].flags = 0; + zfd[fd].filesize = 0; + set_desc(fd,np); + } +} + + +/* ZCLSND -- Close a network device. + */ +ZCLSND (fd, status) +XINT *fd; +XINT *status; +{ + register struct portal *np = get_desc(*fd); + register int flags; + + if (np) { + flags = np->flags; + + if (np->datain > 0) + close (np->datain); + if (np->dataout > 0 && np->dataout != np->datain) + close (np->dataout); + if (np->keepalive > 0) + close (np->keepalive); + + if (flags & F_DEL1) + unlink (np->path1); + if (flags & F_DEL2) + unlink (np->path2); + + free (np); + set_desc(*fd,NULL); + *status = XOK; + + } else + *status = XERR; +} + + +/* ZARDND -- "Asynchronous" binary block read. Initiate a read of at most + * maxbytes bytes from the file FD into the buffer BUF. Status is returned + * in a subsequent call to ZAWTND. + */ +ZARDND (chan, buf, maxbytes, offset) +XINT *chan; /* UNIX file number */ +XCHAR *buf; /* output buffer */ +XINT *maxbytes; /* max bytes to read */ +XLONG *offset; /* 1-indexed file offset to read at */ +{ + register int n; + int fd = *chan; + struct fiodes *kfp = &zfd[fd]; + register struct portal *np = get_desc (fd); + register char *ip; + register XCHAR *op; + int nbytes, maxread; + + /* Determine maximum amount of data to be read. */ + maxread = (np->flags & F_TEXT) ? *maxbytes/sizeof(XCHAR) : *maxbytes; + + /* The following call to select shouldn't be necessary, but it + * appears that, due to the way we open a FIFO with O_NDELAY, read + * can return zero if read is called before the process on the other + * end writes any data. This happens even though fcntl is called to + * restore blocking i/o after the open. + */ + if (np->domain == FIFO && np->datain < MAXSEL) { +#ifdef SOLARIS + fd_set readfds; + FD_ZERO (&readfds); + FD_SET (np->datain, &readfds); +#else + int readfds = (1 << np->datain); +#endif + select (MAXSEL, &readfds, NULL, NULL, NULL); + nbytes = read (np->datain, (char *)buf, maxread); + } else + nbytes = read (np->datain, (char *)buf, maxread); + + if ((n = nbytes) && (np->flags & F_TEXT)) { + op = (XCHAR *) buf; + op[n] = XEOS; + for (ip = (char *)buf; --n >= 0; ) + op[n] = ip[n]; + nbytes *= sizeof(XCHAR); + } + + kfp->nbytes = nbytes; +} + + +/* ZAWRND -- "Asynchronous" binary block write. Initiate a write of exactly + * nbytes bytes from the buffer BUF to the file FD. Status is returned in a + * subsequent call to ZAWTND. + */ +ZAWRND (chan, buf, nbytes, offset) +XINT *chan; /* UNIX file number */ +XCHAR *buf; /* buffer containing data */ +XINT *nbytes; /* nbytes to be written */ +XLONG *offset; /* 1-indexed file offset */ +{ + register int fd = *chan; + register struct fiodes *kfp = &zfd[fd]; + register struct portal *np = get_desc (fd); + int nwritten, maxbytes, n; + char *text, *ip = (char *)buf; + char obuf[SZ_OBUF]; + + maxbytes = (np->domain == FIFO || (np->flags & F_TEXT)) ? SZ_OBUF : 0; + for (nwritten=0; nwritten < *nbytes; nwritten += n, ip+=n) { + n = *nbytes - nwritten; + if (maxbytes) + n = min (maxbytes, n); + + if (np->flags & F_TEXT) { + register XCHAR *ipp = (XCHAR *)ip; + register char *op = (char *)obuf; + register int nbytes = n; + + while (--nbytes >= 0) + *op++ = *ipp++; + text = obuf; + if ((n = write (np->dataout, text, n / sizeof(XCHAR))) < 0) + break; + n *= sizeof(XCHAR); + + } else { + text = ip; + if ((n = write (np->dataout, text, n)) < 0) + break; + } + } + + kfp->nbytes = nwritten; +} + + +/* ZAWTND -- "Wait" for an "asynchronous" read or write to complete, and + * return the number of bytes read or written, or ERR. + */ +ZAWTND (fd, status) +XINT *fd; +XINT *status; +{ + if ((*status = zfd[*fd].nbytes) == ERR) + *status = XERR; +} + + +/* ZSTTND -- Return file status information for a network device. + */ +ZSTTND (fd, param, lvalue) +XINT *fd; +XINT *param; +XLONG *lvalue; +{ + register struct fiodes *kfp = &zfd[*fd]; + struct stat filstat; + + switch (*param) { + case FSTT_BLKSIZE: + (*lvalue) = 0L; + break; + + case FSTT_FILSIZE: + (*lvalue) = 0L; + break; + + case FSTT_OPTBUFSIZE: + /* On some systems this parameter may be device dependent in which + * case device dependent code should be substituted here. + */ + (*lvalue) = ND_OPTBUFSIZE; + break; + + case FSTT_MAXBUFSIZE: + /* On some systems this parameter may be device dependent in which + * case device dependent code should be substituted here. + */ + (*lvalue) = ND_MAXBUFSIZE; + break; + + default: + (*lvalue) = XERR; + break; + } +} + + +/* + * Internal routines. + * ---------------------------- + */ + +/* GETSTR -- Internal routine to extract a colon delimited string from a + * network filename. + */ +static int +getstr (ipp, obuf, maxch) +char **ipp; +char *obuf; +int maxch; +{ + register char *ip = *ipp, *op = obuf; + register char *otop = obuf + maxch; + char *start; + + while (isspace(*ip)) + ip++; + for (start=ip; *ip; ip++) { + if (*ip == ':') { + ip++; + break; + } else if (op && op < otop) + *op++ = *ip; + } + + if (op) + *op = '\0'; + *ipp = ip; + + return (ip - start); +} |