From fa080de7afc95aa1c19a6e6fc0e0708ced2eadc4 Mon Sep 17 00:00:00 2001 From: Joseph Hunkeler Date: Wed, 8 Jul 2015 20:46:52 -0400 Subject: Initial commit --- vendor/x11iraf/ximtool/clients/wcspix/README | 0 vendor/x11iraf/ximtool/clients/wcspix/class.com | 6 + vendor/x11iraf/ximtool/clients/wcspix/mkpkg | 16 + vendor/x11iraf/ximtool/clients/wcspix/t_wcspix.x | 792 ++++++++++ vendor/x11iraf/ximtool/clients/wcspix/wcimage.x | 1465 +++++++++++++++++++ .../x11iraf/ximtool/clients/wcspix/wcimage.x.bak | 1515 ++++++++++++++++++++ vendor/x11iraf/ximtool/clients/wcspix/wcmef.x | 50 + vendor/x11iraf/ximtool/clients/wcspix/wcmspec.x | 50 + vendor/x11iraf/ximtool/clients/wcspix/wcspix.h | 112 ++ vendor/x11iraf/ximtool/clients/wcspix/wcunknown.x | 185 +++ 10 files changed, 4191 insertions(+) create mode 100644 vendor/x11iraf/ximtool/clients/wcspix/README create mode 100644 vendor/x11iraf/ximtool/clients/wcspix/class.com create mode 100644 vendor/x11iraf/ximtool/clients/wcspix/mkpkg create mode 100644 vendor/x11iraf/ximtool/clients/wcspix/t_wcspix.x create mode 100644 vendor/x11iraf/ximtool/clients/wcspix/wcimage.x create mode 100644 vendor/x11iraf/ximtool/clients/wcspix/wcimage.x.bak create mode 100644 vendor/x11iraf/ximtool/clients/wcspix/wcmef.x create mode 100644 vendor/x11iraf/ximtool/clients/wcspix/wcmspec.x create mode 100644 vendor/x11iraf/ximtool/clients/wcspix/wcspix.h create mode 100644 vendor/x11iraf/ximtool/clients/wcspix/wcunknown.x (limited to 'vendor/x11iraf/ximtool/clients/wcspix') diff --git a/vendor/x11iraf/ximtool/clients/wcspix/README b/vendor/x11iraf/ximtool/clients/wcspix/README new file mode 100644 index 00000000..e69de29b diff --git a/vendor/x11iraf/ximtool/clients/wcspix/class.com b/vendor/x11iraf/ximtool/clients/wcspix/class.com new file mode 100644 index 00000000..c6116c11 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients/wcspix/class.com @@ -0,0 +1,6 @@ +# Class common. +int cl_nclass # number of defined functions +int cl_table[LEN_CLASS,MAX_CLASSES] # class table +char cl_names[SZ_CLNAME,MAX_CLASSES] # class names +common /class_com/ cl_nclass, cl_table, cl_names + diff --git a/vendor/x11iraf/ximtool/clients/wcspix/mkpkg b/vendor/x11iraf/ximtool/clients/wcspix/mkpkg new file mode 100644 index 00000000..80b80f48 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients/wcspix/mkpkg @@ -0,0 +1,16 @@ +# Make the WCSPIX ISM Client task. + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + t_wcspix.x wcspix.h class.com + wcimage.x wcspix.h \ + wcspix.h + wcmef.x wcspix.h + wcmspec.x wcspix.h + wcunknown.x wcspix.h + ; + diff --git a/vendor/x11iraf/ximtool/clients/wcspix/t_wcspix.x b/vendor/x11iraf/ximtool/clients/wcspix/t_wcspix.x new file mode 100644 index 00000000..b0170f5b --- /dev/null +++ b/vendor/x11iraf/ximtool/clients/wcspix/t_wcspix.x @@ -0,0 +1,792 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include "wcspix.h" + + +# T_WCSPIX -- Entry point for the WCSPIX Image Support Module for XImtool. +# The WCSPIX task is responsible for converting image coordinates and getting +# pixel values from images of various types. Results are returned to the +# GUI directly using ISM messaging. + +procedure t_wcspix () + +pointer wp +real x, y +int len, disconnect, ncmd, objid, regid +char socket[SZ_FNAME], cmd[SZ_FNAME], message[SZ_LINE], buf[SZ_DATE] +char ref[SZ_FNAME], template[SZ_LINE], param[SZ_FNAME] +bool debug + +long clktime() +pointer wp_init() +int envgets(), envgeti(), strdic() + +# Standard declarations for the Ximtool WCSPIX client interface. +int ism_connect(), wp_read(), ism_intrhandler() +errchk wp_read, envgets, envgeti + +begin + # Initialize local storage. + call aclrc (buf, SZ_DATE) + call aclrc (cmd, SZ_FNAME) + call aclrc (ref, SZ_FNAME) + call aclrc (param, SZ_FNAME) + call aclrc (socket, SZ_FNAME) + call aclrc (message, SZ_LINE) + call aclrc (template, SZ_LINE) + + # Get the connection socket name from the environment if defined + # or else use the default socket. + if (envgets ("ISMDEV", socket, SZ_FNAME) <= 0) + call strcpy (WCSPIX_CONNECT, socket, SZ_FNAME) + + # Open the socket connection on a negotiated socket. + if (ism_connect (socket, WCSPIX_NAME, WCSPIX_MODE) == ERR) + return + + # Install an interrupt exception handler so we can exit cleanly. + if (ism_intrhandler() == ERR) + return + + + # Initialize the task data structures. + wp = wp_init () + + # Check for a runtime debug level. + iferr (WP_DBGLEVEL(wp) = envgeti ("WCSPIX_DEBUG")) + WP_DBGLEVEL(wp) = 0 + + # Log the connection. + call wp_cnvdate (clktime(0), buf, SZ_DATE) + call sprintf (message, SZ_LINE, "info { %s: WCSPIX Connect}\n") + call pargstr (buf) + call ism_message ("ism_msg", message) + + # Loop over the commands read on the connection and process. + disconnect = 1 + debug = (WCSPIX_DBG || WP_DBGLEVEL(wp) > 0) + while (wp_read (wp, message, len) != EOF) { + + if (debug) { + message[len] = '\0' + call eprintf("message: '%s' len=%d\n") + call pargstr (message); call pargi (len) + } + if (len <= 0) { + # Server has disconnected. + disconnect = 0 + break + } + + # Scan the command string and get the first word. + call sscan (message) + call gargwrd (cmd, SZ_LINE) + ncmd = strdic (cmd, cmd, SZ_LINE, WCSPIX_CMDS) + + switch (ncmd) { + case QUIT: + # Server wants us to shut down. + disconnect = 0 + break + + case INITIALIZE: + call wp_cnvdate (clktime(0), buf, SZ_DATE) + call sprintf (message, SZ_LINE, + "info { %s: WCSPIX Initialize}\n") + call pargstr (buf) + call wp_initialize (wp) + + case CACHE: + # + call gargwrd (ref, SZ_FNAME) + call gargi (objid) + call gargi (regid) + if (debug) { + call printf ("cache: objid=%d regid=%d ref='%s'\n") + call pargi(objid); call pargi(regid); call pargstr(ref) + } + + # Log the event. + call wp_cnvdate (clktime(0), buf, SZ_DATE) + call sprintf (message, SZ_LINE, + "info { %s: WCSPIX Cache objid=%3d %s}\n") + call pargstr (buf) + call pargi (objid) + call pargstr (ref) + call ism_message ("ism_msg", message) + + call wp_cache (wp, objid, regid, ref) + + case UNCACHE: + # + call gargi (objid) + if (debug) { call printf("uncache: id=%d\n");call pargi(objid) } + + # Log the event. + call wp_cnvdate (clktime(0), buf, SZ_DATE) + call sprintf (message, SZ_LINE, + "info { %s: WCSPIX Uncache objid=%3d}\n") + call pargstr (buf) + call pargi (objid) + call ism_message ("ism_msg", message) + + call wp_uncache (wp, objid) + + case WCSTRAN: + # [[ ] ["NDC" ]] + call gargi (objid) + call gargr (x) ; call gargr (y) + if (debug) { + call printf ("wcstran: id=%d (%g,%g)\n") + call pargi(objid); call pargr (x); call pargr (y) + } + call wp_wcstran (wp, objid, x, y) + + case WCSLIST: + # + call gargi (objid) + if (debug) { call printf ("wcslist: id=%d\n");call pargi(objid)} + call wp_wcslist (wp, objid) + + case OBJINFO: + # + call gargi (objid) + call gargwrd (template, SZ_FNAME) + if (debug) { + call printf ("objinfo: id=%d temp='%s'\n") + call pargi(objid); call pargstr (template); + } + call wp_objinfo (wp, objid, template) + + case SET: + # + call gargwrd (param, SZ_FNAME) + call wp_setpar (wp, param) + + case GET: + # + + case DEBUG: + debug = !(debug) + + default: + if (debug) { + call eprintf ("ISM default: len=%d msg='%s'\n") + call pargi(len); call pargstr(message) + } + } + + # Clear the buffer for the next read. + call aclrc (message, SZ_LINE) + } + + # Disconnect from the server and clean up. + call ism_disconnect (disconnect) + call wp_shutdown (wp) +end + + +# WP_INITIALIZE -- Initialize the WCSPIX, uncache any previously cached images. + +procedure wp_initialize (wp) + +pointer wp #i WCSPIX structure + +pointer cp, wp_id2obj() +int i + +begin + for (i=0; i < SZ_CACHE; i=i+1) { + cp = wp_id2obj (wp, i) + if (cp != NULL && C_OBJID(cp) != NULL) + call wp_uncache (wp, C_OBJID(cp)) + } +end + + +# WP_CACHE -- Associate and object reference with a unique object id. + +procedure wp_cache (wp, objid, regid, ref) + +pointer wp #i WCSPIX structure +int objid #i object id +int regid #i region id +char ref[ARB] #i object ref + +pointer cp +int i, class +char alert[SZ_FNAME] + +int wp_class() + +include "class.com" + +begin + # Find an unused slot in the object cache. + for (i=0; i < SZ_CACHE; i=i+1) { + cp = OBJCACHE(wp,i) + if (C_NREF(cp) == 0) + break + } + + # Get the object class. + class = wp_class (ref) + if (class == ERR) { + # Send alert to the GUI. + call sprintf (alert, SZ_FNAME, "wp_cache: Unable to cache\n%s") + call pargstr (ref) + call ism_alert (alert, "", "") + + # Setup for linear system. + return + } + C_CLASS(cp) = class + + # Initialize the object. + if (class != NULL && CL_INIT(class) != NULL) + call zcall2 (CL_INIT(class), cp, wp) + + # Call the cache function. + if (class != NULL && CL_CACHE(class) != NULL) + call zcall4 (CL_CACHE(class), cp, objid, regid, ref) +end + + +# WP_UNCACHE -- Remove an object from the WCSPIX cache. + +procedure wp_uncache (wp, id) + +pointer wp #i WCSPIX structure +int id #i object id + +pointer cp, wp_id2obj() +int class + +include "class.com" + +begin + cp = wp_id2obj (wp, id) + if (cp == NULL) + return + + # Call the uncache function. + class = C_CLASS(cp) + if (class != NULL && CL_UNCACHE(class) != NULL) + call zcall2 (CL_UNCACHE(class), cp, id) + + C_NREF(cp) = 0 +end + + +# WP_WCSTRAN -- Translate image coords to WCS values. + +procedure wp_wcstran (wp, id, x, y) + +pointer wp #i WCSPIX structure +int id #i object id +real x, y #i image coords + +pointer cp, wp_id2obj() +int class + +include "class.com" + +begin + cp = wp_id2obj (wp, id) + if (cp == NULL) + return + + # Call the uncache function. + class = C_CLASS(cp) + if (class != NULL && CL_WCSTRAN(class) != NULL) + call zcall4 (CL_WCSTRAN(class), cp, id, x, y) +end + + +# WP_WCSLIST -- List the available world coordinate systems for the given +# object. + +procedure wp_wcslist (wp, id) + +pointer wp #i WCSPIX structure +int id #i object id + +pointer cp, wp_id2obj() +int class + +include "class.com" + +begin + cp = wp_id2obj (wp, id) + if (cp == NULL) + return + + # Call the uncache function. + class = C_CLASS(cp) + if (class != NULL && CL_WCSLIST(class) != NULL) + call zcall2 (CL_WCSLIST(class), cp, id) +end + + +# WP_OBJINFO -- Get and image header or keyword templates for the given +# object. + +procedure wp_objinfo (wp, id, template) + +pointer wp #i WCSPIX structure +int id #i object id +char template[ARB] #i keyword template + +pointer cp, wp_id2obj() +int class + +include "class.com" + +begin + cp = wp_id2obj (wp, id) + if (cp == NULL) + return + + # Call the uncache function. + class = C_CLASS(cp) + if (class != NULL && CL_OBJINFO(class) != NULL) + call zcall3 (CL_OBJINFO(class), cp, id, template) +end + + +# WP_SETPAR -- Set the value of a WCSPIX ISM parameter. + +procedure wp_setpar (wp, param) + +pointer wp #i WCSPIX structure pointer +char param[SZ_FNAME] #i WCSPIX param name + +char arg[SZ_PARAM], buf[SZ_PARAM], msg[SZ_PARAM] +int line + +int strdic() + +include "class.com" + +begin + if (WCSPIX_DBG) { call printf ("set: %s = ");call pargstr(param) } + + switch (strdic (param, param, SZ_PARAM, WCSPIX_PARAMS)) { + case PAR_PSIZE: + call gargi (WP_PTABSZ(wp)) + if (WCSPIX_DBG) { call printf ("%d\n");call pargi(WP_PTABSZ(wp)) } + + case PAR_BPM: + call gargi (WP_BPM(wp)) + if (WCSPIX_DBG) { call printf ("%d\n");call pargi(WP_BPM(wp)) } + + case PAR_WCS: + call gargwrd (buf, SZ_FNAME) + call gargi (line) + + call strcpy (buf, arg, SZ_PARAM) + call strlwr (buf) + switch (strdic (buf, buf, SZ_FNAME, WCSPIX_SYSTEMS)) { + case SYS_DISPLAY: SYSTEMS(wp,line) = SYS_DISPLAY + case SYS_LOGICAL: SYSTEMS(wp,line) = SYS_LOGICAL + case SYS_PHYSICAL: SYSTEMS(wp,line) = SYS_PHYSICAL + case SYS_WORLD: SYSTEMS(wp,line) = SYS_WORLD + case SYS_NONE: SYSTEMS(wp,line) = SYS_NONE + case SYS_AMP: SYSTEMS(wp,line) = SYS_AMP + case SYS_CCD: SYSTEMS(wp,line) = SYS_PHYSICAL + case SYS_DETECTOR: SYSTEMS(wp,line) = SYS_DETECTOR + default: SYSTEMS(wp,line) = SYS_SKY + } + call strcpy (buf, WCSNAME(wp,line), LEN_WCSNAME) + + if (WCSPIX_DBG) { + call printf("%s line=%d\n");call pargstr(buf);call pargi(line) } + + call sprintf (msg, SZ_FNAME, "wcstype %s %d") + call pargstr (arg) + call pargi (line) + call wcspix_message (msg) + + case PAR_FMT: + call gargwrd (buf, SZ_FNAME) + call gargi (line) + + call strcpy (buf, arg, SZ_PARAM) + call strlwr (buf) + switch (strdic (buf, buf, SZ_FNAME, WCSPIX_FMT)) { + case FMT_DEFAULT: FORMATS(wp,line) = FMT_DEFAULT + case FMT_HMS: FORMATS(wp,line) = FMT_HMS + case FMT_DEG: FORMATS(wp,line) = FMT_DEG + case FMT_RAD: FORMATS(wp,line) = FMT_RAD + default: FORMATS(wp,line) = FMT_DEFAULT + } + + if (WCSPIX_DBG) { + call printf("%s line=%d\n");call pargstr(buf);call pargi(line) } + + call sprintf (msg, SZ_FNAME, "wcsfmt %s %d") + call pargstr (arg) + call pargi (line) + call wcspix_message (msg) + } +end + + +# WP_GETPAR -- Get the value of a WCSPIX ISM parameter. + +procedure wp_getpar (wp, param) + +pointer wp #i WCSPIX structure pointer +char param[SZ_FNAME] #i WCSPIX param name + +int strdic() + +begin + if (WCSPIX_DBG) { call printf ("set: %s = ");call pargstr(param) } + + switch (strdic (param, param, SZ_PARAM, WCSPIX_PARAMS)) { + case PAR_PSIZE: + case PAR_BPM: + case PAR_WCS: + case PAR_FMT: + } +end + + +################################################################################ +# +# Private procedures. +# +################################################################################ + + +# WP_INIT -- Initialize the WCSPIX task and data structures. + +pointer procedure wp_init () + +pointer wp #r WCSPIX structure pointer +int i + +begin + # Allocate the task structure. + iferr (call calloc (wp, SZ_WCSPIX, TY_STRUCT)) + call error (0, "Error opening WCSPIX task structure.") + + call calloc (WP_SYSTEMS(wp), MAX_WCSLINES, TY_INT) + call calloc (WP_FORMATS(wp), MAX_WCSLINES, TY_INT) + call calloc (WP_WCS(wp), (LEN_WCSNAME*MAX_WCSLINES), TY_CHAR) + for (i=1; i <= MAX_WCSLINES; i=i+1) { + FORMATS(wp,i) = DEF_FMT + SYSTEMS(wp,i) = DEF_SYSTEM + call strcpy ("none", WCSNAME(wp,i), LEN_WCSNAME) + } + + # Allocate the object cache. + call calloc (WP_CPTR(wp), SZ_CACHE, TY_STRUCT) + for (i=0; i < SZ_CACHE; i=i+1) + call calloc (OBJCACHE(wp,i), SZ_CNODE, TY_STRUCT) + + WP_PTABSZ(wp) = 0 + WP_BPM(wp) = DEF_BPM_FLAG + + # Initialize the class modules. + call wp_class_init() + + return (wp) +end + + +# WP_READ -- Read messages from the connection and process them optimally for +# this ISM. This means we segment the messages and handle only the last +# few WCS requests so we can keep up with the server requests. Presumably +# there are more cursor events coming which are no longer valid so some are +# thrown out. + +int procedure wp_read (wp, message, len) + +pointer wp #i WCSPIX structure pointer +char message[ARB] #o message buffer +int len #o length of message + +int nleft + +int ism_read(), strncmp() +errchk ism_read + +begin + while (true) { + nleft = ism_read (message, len) + + # Return EOF if the server hung up on us. + if (nleft == EOF) + return (EOF) + + # In debug mode process all messages. + if (WP_DBGLEVEL(wp) > 0) + break + + # Pass back all non-wcstran messages. + if (strncmp ("wcstran", message, 7) != 0) + break + + # Only pass back the last wcstran messages received (eat the rest). + if (strncmp ("wcstran", message, 7) == 0 && nleft <= 1) + break + } + + return (len) +end + + +# WP_SHUTDOWN -- Shut down the WCSPIX, freeing all storage + +procedure wp_shutdown (wp) + +pointer wp #i WCSPIX structure +int i + +begin + # Free the structures. + call mfree (WP_WCS(wp), TY_CHAR) + call mfree (WP_FORMATS(wp), TY_INT) + call mfree (WP_SYSTEMS(wp), TY_INT) + for (i=0; i < SZ_CACHE; i=i+1) + call mfree (OBJCACHE(wp,i), TY_STRUCT) + + call mfree (WP_CPTR(wp), TY_STRUCT) + call mfree (wp, TY_STRUCT) +end + + +# WP_CLASS -- Determine the object class for the named image/file. + +int procedure wp_class (object) + +char object[ARB] #i object reference + +int n, class +pointer im +char ch, buf[SZ_FNAME] + +int strlen(), stridx() +bool streq() +pointer immap() + +errchk immap + +begin + # The following kludge is necessary to protect against the case + # where dev$pix is used as a test image. The 'object' pathname in + # this case is "node!/path/dev/pix" which lacks the extension + # and causes the task to fail to open because of a conflict with + # the pix.hhh in the same directory. Most IRAF tasks work since + # the imio$iki code treats the string "dev$pix" as a special case. + + call imgimage (object, buf, SZ_FNAME) + n = strlen (buf) - 7 + if (streq (buf[n], "/dev/pix")) { + call strcpy ("dev$pix", buf, SZ_FNAME) + ch = '[' + n = stridx (ch, object) + if (n > 0) + call strcat (object[n], buf, SZ_FNAME) + call strcpy (buf, object, SZ_FNAME) + } + + + # See if we can map the image to get at least an image class. If + # so then check for special subclasses like Mosaic files, spectra, etc. + + class = UNKNOWN_CLASS + ifnoerr (im = immap (object, READ_ONLY, 0)) { + class = IMAGE_CLASS + + # Now check for subclasses. (TBD) + + call imunmap (im) + } + + return (class) +end + + +# WP_ID2OBJ -- Utility routine to convert and object id to the cache pointer. + +pointer procedure wp_id2obj (wp, id) + +pointer wp #i WCSPIX structure +int id #i object id + +int i +pointer cp + +begin + for (i=0; i < SZ_CACHE; i=i+1) { + cp = OBJCACHE(wp,i) + if (C_OBJID(cp) == id) + return (cp) + } + return (NULL) +end + + +# WP_CLASS_INIT -- Initialize the WCSPIX ISM class modules. + +procedure wp_class_init() + +extern img_init(), img_cache(), img_uncache() +extern img_wcstran(), img_wcslist(), img_objinfo() + +extern mef_init(), mef_cache(), mef_uncache() +extern mef_wcstran(), mef_wcslist(), mef_objinfo() + +extern msp_init(), msp_cache(), msp_uncache() +extern msp_wcstran(), msp_wcslist(), msp_objinfo() + +extern unk_init(), unk_cache(), unk_uncache() +extern unk_wcstran(), unk_wcslist(), unk_objinfo() + +include "class.com" +int locpr() + +begin + cl_nclass = 0 + + # Load the class modules. + call wp_load_class ("unknown", + locpr(unk_init), locpr(unk_cache), locpr(unk_uncache), + locpr(unk_wcstran), locpr(unk_wcslist), locpr(unk_objinfo)) + call wp_load_class ("image", + locpr(img_init), locpr(img_cache), locpr(img_uncache), + locpr(img_wcstran), locpr(img_wcslist), locpr(img_objinfo)) + call wp_load_class ("mef", + locpr(mef_init), locpr(mef_cache), locpr(mef_uncache), + locpr(mef_wcstran), locpr(mef_wcslist), locpr(mef_objinfo)) + call wp_load_class ("multispec", + locpr(msp_init), locpr(msp_cache), locpr(msp_uncache), + locpr(msp_wcstran), locpr(msp_wcslist), locpr(msp_objinfo)) +end + + +# WP_LOAD_CLASS -- Load an object class module for the ISM task. + +procedure wp_load_class (name, init, cache, uncache, tran, list, info) + +char name[ARB] #I module name +int init #I initialize procedure +int cache #I cache the object procedure +int uncache #I uncache the object procedure +int tran #I translate WCS procedure +int list #I list WCS proedure +int info #I get header procedure + +errchk syserrs +include "class.com" + +begin + # Get a new driver slot. + if (cl_nclass + 1 > MAX_CLASSES) + return + cl_nclass = cl_nclass + 1 + + # Load the driver. + CL_INIT(cl_nclass) = init + CL_CACHE(cl_nclass) = cache + CL_UNCACHE(cl_nclass) = uncache + CL_WCSTRAN(cl_nclass) = tran + CL_WCSLIST(cl_nclass) = list + CL_OBJINFO(cl_nclass) = info + call strcpy (name, CL_NAME(cl_nclass), SZ_FNAME) +end + + +# WCSPIX_MESSAGE -- Deliver a message to the ISM callback, tagged with +# our name so it can be passed off to the correct code. + +procedure wcspix_message (message) + +char message[ARB] #I message to send + +pointer sp, msgbuf +int msglen, mlen, ip + +int strlen() + +begin + # Get the message length plus some extra for the braces and padding. + mlen = strlen (message) + msglen = mlen + 64 + + # Allocate and clear the message buffer. + call smark (sp) + call salloc (msgbuf, msglen, TY_CHAR) + call aclrc (Memc[msgbuf], msglen) + + ip = 0 + call amovc ("deliver wcspix { ", Memc[msgbuf], 17) ; ip = ip + 17 + call amovc (message, Memc[msgbuf+ip], mlen) ; ip = ip + mlen + call amovc (" }\0", Memc[msgbuf+ip], 2) ; ip = ip + 2 + + call ism_message ("ism_msg", Memc[msgbuf]) + + call sfree (sp) +end + + +define SZ_WEEKDAY 3 +define SZ_MONTH 3 + +# WP_CNVDATE -- Convert a time in integer seconds since midnight on Jan 1, 1980 +# into a short string such as "5/15 18:24". + +procedure wp_cnvdate (ltime, outstr, maxch) + +long ltime # seconds since 00:00:00 10-Jan-1980 +char outstr[ARB] +int maxch + +int tm[LEN_TMSTRUCT] + +begin + call brktime (ltime, tm) + +# call sprintf (outstr, maxch, "%2d/%2d %2d:%02d") +# call pargi (TM_MONTH(tm)) +# call pargi (TM_MDAY(tm)) +# call pargi (TM_HOUR(tm)) +# call pargi (TM_MIN(tm)) + +# call sprintf (outstr, maxch, "%2d:%02d") +# call pargi (TM_HOUR(tm)) +# call pargi (TM_MIN(tm)) + + call sprintf (outstr, maxch, "%2d:%02d:%02d") + call pargi (TM_HOUR(tm)) + call pargi (TM_MIN(tm)) + call pargi (TM_SEC(tm)) +end + + + +#---------------- +# DEBUG ROUTINES. +#---------------- +procedure dbg_printcache (wp, buf) +pointer wp +char buf[ARB] +pointer cp, wp_id2obj() +int i +begin + call printf ("%s\n") ; call pargstr (buf) + for (i=0; i < SZ_CACHE; i=i+1) { + cp = wp_id2obj (wp, i) + if (C_DATA(cp) != NULL) { + call printf ("%3d: id=%d ref='%s'\n") + call pargi(i) + call pargi(C_OBJID(cp)) + call pargstr(C_REF(cp)) + } + } +end diff --git a/vendor/x11iraf/ximtool/clients/wcspix/wcimage.x b/vendor/x11iraf/ximtool/clients/wcspix/wcimage.x new file mode 100644 index 00000000..4a27af46 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients/wcspix/wcimage.x @@ -0,0 +1,1465 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include +include +include "wcspix.h" + + +# Image class data. +define LEN_IMGDATA 15 +define IMG_WP Memi[$1 ] # wcspix back-pointer +define IMG_IM Memi[$1+1] # image pointer +define IMG_BPM Memi[$1+2] # bad pixel mask pointer +define IMG_MW Memi[$1+3] # image wcs pointer +define IMG_CO Memi[$1+4] # skywcs transform pointer +define IMG_CTW Memi[$1+5] # mwcs log->world transform ptr +define IMG_CTP Memi[$1+6] # mwcs log->phys transform ptr +define IMG_CTA Memi[$1+7] # mwcs log->amplifier transform +define IMG_CTD Memi[$1+8] # mwcs log->detector transform +define IMG_ROT Memr[$1+9] # rotation angle +define IMG_SCALE Memr[$1+10] # plate scale +define IMG_LINEAR Memi[$1+11] # linear coords + + +define IMG_DEBUG FALSE + + +# IMG_INIT -- Initialize the object structure. + +procedure img_init (cp, wp) + +pointer cp #i cache pointer +pointer wp #i WCSPIX structure + +pointer img # data pointer + +begin + if (IMG_DEBUG) call printf ("img_init: \n") + + # Allocate the image data structure if not previously allocated. + if (C_DATA(cp) == NULL) { + iferr (call calloc (C_DATA(cp), LEN_IMGDATA, TY_STRUCT)) + return + } + + img = C_DATA(cp) + IMG_WP(img) = wp + IMG_IM(img) = NULL + IMG_BPM(img) = NULL + IMG_MW(img) = NULL + IMG_CO(img) = NULL + IMG_CTW(img) = NULL + IMG_CTP(img) = NULL + IMG_CTA(img) = NULL + IMG_CTD(img) = NULL + IMG_ROT(img) = 0.0 + IMG_SCALE(img) = 0.0 + IMG_LINEAR(img) = YES +end + + +# IMG_CACHE -- Cache an image in the object cache. + +procedure img_cache (cp, objid, regid, ref) + +pointer cp #i cache pointer +int objid #i object id +int regid #i region id +char ref[ARB] #i object reference + +pointer img, im, wp, co +int stat, i1, i2 +char alert[SZ_LINE] + +pointer immap(), ds_pmmap(), mw_sctran() +pointer img_amp_wcs(), img_det_wcs() +int imaccf(), sk_decim() + +errchk immap, ds_pmmap, mw_sctran, sk_decim, sk_setd + +begin + if (IMG_DEBUG) call printf ("img_cache: \n") + + # Now map the image and WCS. + img = C_DATA(cp) + wp = IMG_WP(img) + + iferr (IMG_IM(img) = immap (ref, READ_ONLY, 0)) { + # Send alert to the GUI. + call sprintf (alert, SZ_FNAME, "Unable to cache\n%s") + call pargstr (ref) + call ism_alert (alert, "", "") + return + } + im = IMG_IM(img) + + IMG_CO(img) = NULL + IMG_CTW(img) = NULL + IMG_CTP(img) = NULL + IMG_CTA(img) = NULL + IMG_CTD(img) = NULL + iferr { + stat = sk_decim (IMG_IM(img), "world", IMG_MW(img), IMG_CO(img)) + if (IMG_DEBUG) { + call eprintf ("img_cache - decim: stat=%d mw=%d co=%d \n") + call pargi(stat);call pargi(IMG_MW(img)) + call pargi(IMG_CO(img)); + } + if (stat == ERR || IMG_MW(img) == NULL) { + IMG_LINEAR(img) = YES + + co = IMG_CO(img) + i1 = IM_VMAP(im,1) + i2 = IM_VMAP(im,2) + call sk_setd (co, S_VXOFF, double(IM_VOFF(im,i1))) + call sk_setd (co, S_VYOFF, double(IM_VOFF(im,i2))) + call sk_setd (co, S_VXSTEP, double(IM_VSTEP(im,i1))) + call sk_setd (co, S_VYSTEP, double(IM_VSTEP(im,i2))) + + IMG_MW(img) = NULL + IMG_LINEAR(img) = YES + } + + if (IMG_MW(img) != NULL) { + IMG_CTW(img) = mw_sctran (IMG_MW(img), "logical", "world", 03B) + IMG_CTP(img) = mw_sctran (IMG_MW(img), "logical", "physical", + 03B) + + # Get the amplifier transformation values if present. + if (imaccf(im,"ATM1_1") == YES && + imaccf(im,"ATM2_2") == YES && + imaccf(im,"ATV1") == YES && + imaccf(im,"ATV2") == YES) + IMG_CTA(img) = img_amp_wcs (im, IMG_MW(img)) + + if (imaccf(im,"DTM1_1") == YES && + imaccf(im,"DTM2_2") == YES && + imaccf(im,"DTV1") == YES && + imaccf(im,"DTV2") == YES) + IMG_CTD(img) = img_det_wcs (im, IMG_MW(img)) + } + + } then { + # Send alert to the GUI. + call sprintf (alert, SZ_FNAME, "Unable to decode image WCS\n%s") + call pargstr (ref) + call ism_alert (alert, "", "") + IMG_LINEAR(img) = YES + } + + + # See if we can find a bad pixel mask. + IMG_BPM(img) = NULL + if (WP_BPM(wp) == YES) { + iferr (IMG_BPM(img) = ds_pmmap ("BPM", IMG_IM(img))) + IMG_BPM(img) = NULL + } + + C_OBJID(cp) = objid + C_REGID(cp) = regid + C_NREF(cp) = C_NREF(cp) + 1 + call strcpy (ref, C_REF(cp), 128) +end + + +# IMG_UNCACHE -- Uncache an image in the object cache. + +procedure img_uncache (cp, id) + +pointer cp #i cache pointer +int id #i image id + +pointer img + +begin + if (IMG_DEBUG) call printf ("img_uncache: \n") + + C_OBJID(cp) = NULL + C_NREF(cp) = 0 + call strcpy ("", C_REF(cp), SZ_FNAME) + + img = C_DATA(cp) + if (IMG_MW(img) != NULL) + call mw_close (IMG_MW(img)) + if (IMG_BPM(img) != NULL) + call imunmap (IMG_BPM(img)) + if (IMG_IM(img) != NULL) + call imunmap (IMG_IM(img)) + + IMG_IM(img) = NULL + IMG_BPM(img) = NULL + IMG_MW(img) = NULL + IMG_CTW(img) = NULL + IMG_CTP(img) = NULL + IMG_CTA(img) = NULL + IMG_CTD(img) = NULL + IMG_CO(img) = NULL + IMG_ROT(img) = 0.0 + IMG_SCALE(img) = 0.0 + IMG_LINEAR(img) = NO + + call mfree (C_DATA(cp), TY_STRUCT) + C_DATA(cp) = NULL +end + + +# IMG_WCSTRAN -- Translate object source (x,y) coordinates to the +# desired output WCSs. Message is returned as something like: +# +# set value { +# { object } { region } +# { pixval [] } +# { bpm } +# { coord [ ] } +# { coord [ ] } +# : +# } + + +procedure img_wcstran (cp, id, x, y) + +pointer cp #i cache pointer +int id #i image id +real x, y #i source coords + +pointer img, im, wp, co +double dx, dy, wx, wy +real rx, ry, pixval +int i, bpm + +# Use static storage to avoid allocation overhead. +char buf[SZ_LINE] +char msg[SZ_LINE], wcs[LEN_WCSNAME], xc[LEN_WCSNAME], yc[LEN_WCSNAME] +char xunits[LEN_WCSNAME], yunits[LEN_WCSNAME] + +double sk_statd() + +begin + if (IMG_DEBUG) call printf ("img_wcstran: \n") + + img = C_DATA(cp) # initialize + co = IMG_CO(img) + wp = IMG_WP(img) + im = IMG_IM(img) + + # Get the translation to the image section. + dx = (double(x) - sk_statd(co,S_VXOFF)) / sk_statd(co,S_VXSTEP) + dy = (double(y) - sk_statd(co,S_VYOFF)) / sk_statd(co,S_VYSTEP) + rx = dx + ry = dy + + # Read the pixel data. + call img_get_data (cp, id, rx, ry, pixval, bpm) + + # Begin formatting the message. + call aclrc (msg, SZ_LINE) + call sprintf (msg, SZ_LINE, "wcstran { object %d } { region %d } ") + call pargi (C_OBJID(cp)) + call pargi (C_REGID(cp)) + + call sprintf (buf, SZ_LINE, "{ pixval %9.9g } { bpm %d }\n") + call pargr (pixval) + call pargi (bpm) + call strcat (buf, msg, SZ_LINE) + + # Now loop over the requested systems and generate a coordinate + # for each. + for (i=1; i <= MAX_WCSLINES; i=i+1) { + + # Get the coordinate value. + call img_get_coord (img, dx, dy, SYSTEMS(wp,i), WCSNAME(wp,i), + wx, wy) + + # Get the system name, labels, and formats strings for the WCS. + call img_coord_labels (cp, i, wcs, xunits, yunits) + + # Format the values as requested. + call img_coord_fmt (cp, i, wx, wy, xc, yc) + + # Format the coord buffer and append it to the message. + call sprintf (buf, SZ_LINE, + "{coord {%9s} {%12s} {%12s} {%4s} {%4s}}\n") + call pargstr (wcs) + call pargstr (xc) + call pargstr (yc) + call pargstr (xunits) + call pargstr (yunits) + call strcat (buf, msg, SZ_LINE) + } + + # Now send the completed message. + call wcspix_message (msg); +end + + +# IMG_WCSLIST -- List the WCSs available for the given image. + +procedure img_wcslist (cp, id) + +pointer cp #i cache pointer +int id #i image id + +pointer img, im, mw +char msg[SZ_LINE] + +begin + if (IMG_DEBUG) call printf ("img_wcslist: \n") + + img = C_DATA(cp) # initialize + mw = IMG_MW(img) + im = IMG_IM(img) + + call strcpy ("wcslist {None Display Logical World Physical line ", + msg, SZ_LINE) + + # See if we can do amplifier/detector coords by checking for ATM/ATV + # and DTM/DTV keywords. + + if (IMG_CTA(img) != NULL) + call strcat (" Amplifier ", msg, SZ_LINE) + if (IMG_CTD(img) != NULL) + call strcat (" Detector ", msg, SZ_LINE) + if (IMG_CTA(img) != NULL || IMG_CTD(img) != NULL) + call strcat (" CCD ", msg, SZ_LINE) + + # If we have a MWCS pointer list the sky projections. + if (mw != NULL) { + call strcat (" line ", msg, SZ_LINE) + call strcat (SKYPROJ, msg, SZ_LINE) + } + + # Close the message. + call strcat ("}", msg, SZ_LINE) + + call wcspix_message (msg) +end + + +# IMG_GET_DATA -- Get data from the image. + +procedure img_get_data (cp, id, x, y, pixval, bpm_pix) + +pointer cp #i cache pointer +int id #i image id +real x, y #i source coords +real pixval #o central pixel value +int bpm_pix #o bad pixel mask value + +pointer img, wp, im, bpm, pix, sp, msg, buf +int nl, nc, ix, iy, s2 +int size, x1, x2, y1, y2 + +long clktime() +pointer imgs2r(), imgs2i(), ds_pmmap() +errchk ds_pmmap + +begin + + img = C_DATA(cp) + wp = IMG_WP(img) + im = IMG_IM(img) + bpm = IMG_BPM(img) + nc = IM_LEN(im,1) + nl = IM_LEN(im,2) +# size = WP_PTABSZ(wp) + size = min(min(nc,nl),WP_PTABSZ(wp)) + + if (IMG_DEBUG) { + call printf ("img_get_data: \n") + call eprintf ("\tx: %g y: %g nc: %d nl: %d\n") + call pargr(x); call pargr(y); call pargi(nc); call pargi(nl) + } + + # Sanity check on the cursor image position. + if (x < 0.0 || y < 0.0 || x > (nc+0.5) || y > (nl+0.5)) + return + + # Bounds checking. Rather than deal with out of bounds pixels we'll + # adjust the center pixel so we get the same size raster up to each + # boundary. + + ix = int (x + 0.5) ; iy = int (y + 0.5) + ix = min (ix, (nc-(size/2)-1)) ; iy = min (iy, (nl-(size/2)-1)) + ix = max (size/2+1, ix) ; iy = max (size/2+1, iy) + + # Compute the box offset given the center and size. + x1 = ix - size / 2 + 0.5 + x2 = ix + size / 2 + 0.5 + y1 = iy - size / 2 + 0.5 + y2 = iy + size / 2 + 0.5 + + if (IMG_DEBUG) { + call printf ("img_get_data: \n") + call eprintf ("\tix: %d iy: %g size: %d\n") + call pargi(ix); call pargi(iy); call pargi(size) + call eprintf ("\tx1: %d y1: %d x2: %d y2: %d\n") + call pargi(x1); call pargi(y1); + call pargi(x2); call pargi(y2); + } + + x1 = max (1, x1) + x2 = min (nc, x2) + y1 = max (1, y1) + y2 = min (nl, y2) + + if (IMG_DEBUG) { + call eprintf ("\tx1: %d y1: %d x2: %d y2: %d\n") + call pargi(x1); call pargi(y1); + call pargi(x2); call pargi(y2); + } + + # Get the image pixels + pix = imgs2r (im, int(x1), int(x2), int(y1), int(y2)) + + if (WP_BPM(wp) == YES) { + if (bpm != NULL) { + bpm_pix = Memi[imgs2i (bpm, ix, ix, iy, iy)] + } else { + # See if we can find a bad pixel mask. The option is enabled + # but we haven't mappend the mask yet. + + # Log the event. + call smark (sp) + call salloc (msg, SZ_LINE, TY_CHAR) + call salloc (buf, SZ_LINE, TY_CHAR) + call wp_cnvdate (clktime(0), Memc[buf], SZ_DATE) + call sprintf (Memc[msg], SZ_LINE, + "info { %s: WCSPIX BPM map objid=%3d %s}\n") + call pargstr (Memc[buf]) + call pargi (C_OBJID(cp)) + call pargstr (C_REF(cp)) + call ism_message ("ism_msg", Memc[msg]) + + iferr (IMG_BPM(img) = ds_pmmap ("BPM", im)) { + IMG_BPM(img) = NULL + bpm_pix = 0 + + # Send alert to the GUI. + call sprintf (Memc[buf], SZ_FNAME, + "Unable to map BPM image for\n%s") + call pargstr (C_REF(cp)) + call ism_alert (Memc[buf], "", "") + } else + bpm_pix = Memi[imgs2i (IMG_BPM(img), ix, ix, iy, iy)] + + call sfree (sp) + } + } else + bpm_pix = 0 + + # See if we're near an edge... + s2 = size / 2 + if (int(x)(nl-s2-1) || int(y)(nc-s2-1)) { + # Compute the image pixel associated with the requested coords. + ix = int (x + 0.5) + iy = int (y + 0.5) + pixval = Memr[imgs2r(im, ix, ix, iy, iy)] + } else { + pixval = Memr[pix + ((size/2)*size) + (size/2)] + } + + # Send the pixel table. + if (WP_PTABSZ(wp) > 1) + call img_send_pixtab (Memr[pix], WP_PTABSZ(wp), x1, x2, y1, y2) + + if (IMG_DEBUG) { + call printf ("img_get_data: pixval=%g\n") ; call pargr (pixval) + } +end + + +# IMG_OBJINFO -- Get header information from the image. + +procedure img_objinfo (cp, id, template) + +pointer cp #i cache pointer +int id #i image id +char template[ARB] #i keyword template + +pointer im, img + +define WCS_TEMPLATE "WCSDIM,CTYPE*,CRPIX*,CRVAL*,CD*,CROTA2,LTV*,LTM*,WSV*,WAT*,RA*,DEC*,EQUINOX,EPOCH,MJD*,DATE-OBS" + +begin + if (IMG_DEBUG) call printf ("img_objinfo: \n") + + # Send the full header (or keyword filtered header), only the WCS + # keywords, and a plain-text explanation of the WCS. + + img = C_DATA(cp) + im = IMG_IM(img) + + call img_send_header (im, "imghdr", template) + call img_send_header (im, "wcshdr", WCS_TEMPLATE) + call img_send_wcsinfo (im, cp) + call img_send_compass (im, cp) +end + + + +#============================================================================== + +# IMG_SEND_HEADER -- Send an image header to the named GUI object. Keywords +# are filtered according to a specified template + +procedure img_send_header (im, object, template) + +pointer im #i image descriptor +char object[ARB] #i object for the message +char template[ARB] #i keyword template + +pointer sp, hdr, lbuf, line, field, keyw, dict +pointer ip, lp, list +int nlines, in, out, i, hdr_size +bool keyw_filter + +int stropen(), getline(), stridx(), imgnfn(), strdic() +pointer imofnlu() +bool streq() +errchk stropen, getline, putci, putline, imgnfn, imofnlu, strdic + +define USER_AREA Memc[($1+IMU-1)*SZ_STRUCT + 1] +define SZ_KEYW 8 + +begin + hdr_size = (LEN_IMDES + IM_LENHDRMEM(im) - IMU) * SZ_STRUCT - 1 + hdr_size = hdr_size + SZ_LINE + + call smark (sp) + call salloc (hdr, hdr_size, TY_CHAR) + call salloc (dict, hdr_size, TY_CHAR) + call salloc (field, SZ_LINE, TY_CHAR) + call salloc (lbuf, SZ_LINE, TY_CHAR) + call salloc (line, SZ_LINE, TY_CHAR) + call salloc (keyw, SZ_KEYW, TY_CHAR) + + in = stropen (USER_AREA(im), hdr_size, READ_ONLY) + out = stropen (Memc[hdr], hdr_size, WRITE_ONLY) + call fprintf (out, "%s {") + call pargstr (object) + + # Build up a dictionary of header keywords based on the template. + keyw_filter = (!streq (template, "*")) + if (keyw_filter) { + list = imofnlu (im, template) + call strcpy ("|", Memc[dict], hdr_size) + while (imgnfn (list, Memc[field], SZ_FNAME) != EOF) { + call strcat (Memc[field], Memc[dict], hdr_size) + call strcat ("|", Memc[dict], hdr_size) + } + call imcfnl (list) + } + + + # Copy header records to the output, stripping any trailing + # whitespace and clipping at the right margin. We also filter + # against the keyword dictionary found above. + + nlines = 0 + while (getline (in, Memc[lbuf]) != EOF) { + + call aclrc (Memc[line], SZ_LINE) + + # Escape any brackets passed to the Tcl. + ip = lbuf + lp = line + while (Memc[ip] != EOS && Memc[ip] != '\n') { + if (stridx (Memc[ip], "[{") > 0) { + Memc[lp] = '\\' + lp = lp + 1 + } + Memc[lp] = Memc[ip] + ip = ip + 1 + lp = lp + 1 + } + Memc[lp] = '\n' + Memc[lp+1] = EOS + + # See whether the line matches a keyword we want to output. + if (keyw_filter) { + for (i=0; i < SZ_KEYW && !IS_WHITE(Memc[line+i]); i=i+1) + Memc[keyw+i] = Memc[line+i] + Memc[keyw+i] = '\0' + + # If not in the dictionary skip to the next line. + if (strdic (Memc[keyw], Memc[keyw], SZ_KEYW, Memc[dict]) == 0) + next + } + + call putci (out, ' ') + call putline (out, Memc[line]) + + # Send the header in small chunks so we don't overflow the + # message buffer. + nlines = nlines + 1 + if (mod(nlines,10) == 0) { + call fprintf (out, "}") + call close (out) + call wcspix_message (Memc[hdr]); + call aclrc (Memc[hdr], hdr_size) + out = stropen (Memc[hdr], hdr_size, WRITE_ONLY) + call fprintf (out, "%s {") + call pargstr (object) + } + } + call fprintf (out, "}") + + call close (in) + call close (out) + + # Send the final message. + call wcspix_message (Memc[hdr]) + + # Pad a few lines for the GUI + call sprintf (Memc[hdr], SZ_LINE, "%d { \n\n\n }") + call pargstr (object) + call wcspix_message (Memc[hdr]) + + call sfree (sp) +end + + +# IMG_SEND_COMPASS -- Send information about the image WCS in a plain-english +# string. + +procedure img_send_compass (im, cp) + +pointer im #i image descriptor +pointer cp #i cache element pointer + +pointer sp, buf, img, co, mw +double r[IM_MAXDIM], w[IM_MAXDIM], cd[IM_MAXDIM,IM_MAXDIM] +int i, j +long axis[IM_MAXDIM], lv[IM_MAXDIM], pv1[IM_MAXDIM], pv2[IM_MAXDIM] + +real north[2], east[2] + +int mw_stati(), sk_stati() + +begin + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + call aclrc (Memc[buf], SZ_LINE) + + # Get the data pointer. + img = C_DATA(cp) + co = IMG_CO(img) + + # Get world coords at the image corners. + if (IMG_CTW(img) != NULL) { + + # Get the CD matrix for the image. + mw = IMG_MW(img) + call wcs_gfterm (mw, r, w, cd, mw_stati(mw, MW_NPHYSDIM)) + + # Compute a Nort and East vector for the CD matrix. + call img_cvectors (cd, 1.0, north, east) + + } else { + # Determine the logical to physical mapping by evaluating two + # points and determining the axis reduction if any. pv1 will be + # the offset and pv2-pv1 will be the scale. + + lv[1] = 0; lv[2] = 0; call imaplv (im, lv, pv1, 2) + lv[1] = 1; lv[2] = 1; call imaplv (im, lv, pv2, 2) + + i = 1 + axis[1] = 1; axis[2] = 2 + do j = 1, IM_MAXDIM { + if (pv1[j] != pv2[j]) { + axis[i] = j + i = i + 1 + } + } + north[1] = 0.0 + north[2] = (pv2[axis[2]] - pv1[axis[2]]) + east[1] = -(pv2[axis[1]] - pv1[axis[1]]) + east[2] = 0.0 + } + + call sprintf (Memc[buf], SZ_LINE, "compass %d %g %g %g %g %g %d %s\0") + call pargi (C_OBJID(cp)) + call pargr (IMG_ROT(img)) + call pargr (north[1]) + call pargr (north[2]) + call pargr (east[1]) + call pargr (east[2]) + if (sk_stati(co,S_PLATAX) < sk_stati(co,S_PLNGAX)) + call pargi (1) # transposed image + else + call pargi (0) + if (IMG_MW(img) != NULL) + call pargstr ("E N") + else + call pargstr ("X Y") + + call wcspix_message (Memc[buf]) + + call sfree (sp) +end + + +# IMG_CVECTORS -- Get north and east vectors for the compass + +procedure img_cvectors (cd, length, north, east) + +double cd[2,2] #i CD matrix +real length #i length of vectors +real north[2] #o vector pointing north +real east[2] #o vector pointing east + +double d # determinant of CD matrix +double x, y # scratch for vector components +double l # length of a vector + +begin + d = cd[1,1] * cd[2,2] - cd[1,2] * cd[2,1] + if (d == 0.d0) + call error (1, "CD matrix is singular") + + # North. + x = -cd[1,2] / d + y = cd[1,1] / d + + # Normalize by the length and copy to output. + l = sqrt (x**2 + y**2) + north[1] = x * length / l + north[2] = y * length / l + + # East. + x = cd[2,2] / d + y = -cd[2,1] / d + l = sqrt (x**2 + y**2) + east[1] = x * length / l + east[2] = y * length / l +end + + +# IMG_SEND_WCSINFO -- Send information about the image WCS in a plain-english +# string. + +procedure img_send_wcsinfo (im, cp) + +pointer im #i image descriptor +pointer cp #i cache element pointer + +pointer sp, co, img, mw +pointer buf, proj, radecstr +int fd, radecsys, ctype, wtype, ndim +double crpix1, crpix2, crval1, crval2, cval1, cval2 +double xscale, yscale, xrot, yrot +double r[IM_MAXDIM], w[IM_MAXDIM], cd[IM_MAXDIM,IM_MAXDIM], + +int idxstr(), sk_stati(), stropen(), mw_stati() +double sk_statd(), sl_epj(), sl_epb() +bool fp_equald() + +errchk stropen + +begin + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + call salloc (proj, SZ_FNAME, TY_CHAR) + call salloc (radecstr, SZ_FNAME, TY_CHAR) + + # Open a string on a file. + fd = stropen (Memc[buf], SZ_LINE, WRITE_ONLY) + + # Get the data pointer. + img = C_DATA(cp) + + # Get the coordinate transform descriptor. + co = IMG_CO(img) + radecsys = sk_stati (co, S_RADECSYS) + ctype = sk_stati (co, S_CTYPE) + wtype = sk_stati (co, S_WTYPE) + + mw = IMG_MW(img) + if (mw != NULL) { + # Now get the mwcs Rterm (CRPIXi), Wterm (CRVALi), and CD matrix. + ndim = mw_stati (mw, MW_NPHYSDIM) + call wcs_gfterm (mw, r, w, cd, ndim) + crpix1 = r[1] + crpix2 = r[2] + crval1 = w[1] + crval2 = w[2] + + xscale = sqrt (cd[1,1]**2 + cd[2,1]**2) * 3600.0d0 + yscale = sqrt (cd[1,2]**2 + cd[2,2]**2) * 3600.0d0 + xrot = 0.0 + yrot = 0.0 + if (!fp_equald (cd[1,1], 0.0d0)) + xrot = DRADTODEG(atan ( cd[2,1] / cd[1,1])) + if (!fp_equald (cd[2,2], 0.0d0)) + yrot = DRADTODEG(atan (-cd[1,2] / cd[2,2])) + } else { + ndim = 2 + xscale = 1.0 + yscale = 1.0 + xrot = 0.0 + yrot = 0.0 + } + + if (IMG_DEBUG) { + call printf("WCS Info:\n=========\n") + call printf("R term: %g %g\n"); call pargd(r[1]); call pargd(r[2]) + call printf("W term: %g %g\n"); call pargd(w[1]); call pargd(w[2]) + call printf(" cd: %g %g\n %g %g\n") + call pargd(cd[1,1]); call pargd(cd[1,2]) + call pargd(cd[2,1]); call pargd(cd[2,2]) + call printf(" scale: %g %g\n");call pargd(xscale);call pargd(yscale) + call printf(" rot: %g %g\n");call pargd(xrot);call pargd(yrot) + } + + IMG_SCALE(img) = (xscale + yscale) / 2.0d0 + #IMG_ROT(img) = (xrot + yrot) / 2.0d0 + IMG_ROT(img) = xrot + + + # Now format a WCS text panel such as + # + # Projection: TAN System: Equatorial FK5 + # Ra/Dec axes: 1/2 Dimensions: 512 x 512 + # + # Center Pos: RA: 13:29:52.856 Dec: +47:11:40.39 + # Reference Pos: RA: 13:29:52.856 Dec: +47:11:40.39 + # Ref pixel coord: X: 250.256 Y: 266.309 + # Plate Scale: 0.765194 Rot Angle: 1.02939 + # Equinox: J2000.000 Epoch: J1987.25775240 + # MJD: 46890.39406 + + # Get some preliminary values. + if (idxstr (radecsys, Memc[radecstr], SZ_FNAME, EQTYPE_LIST) <= 0) + call strcpy ("FK5", Memc[radecstr], SZ_FNAME) + call strupr (Memc[radecstr]) + + if (idxstr (wtype, Memc[proj], SZ_FNAME, WTYPE_LIST) <= 0) + call strcpy ("logical", Memc[proj], SZ_FNAME) + call strupr (Memc[proj]) + + call fprintf (fd, "wcsinfo {\n") + + call fprintf (fd, + " Projection: %-6s\t System: %s %s\n") + call pargstr (Memc[proj]) + switch (ctype) { + case CTYPE_EQUATORIAL: + call pargstr ("Equatorial") + call pargstr (Memc[radecstr]) + case CTYPE_ECLIPTIC: + call pargstr ("Ecliptic") + call pargstr ("") + case CTYPE_GALACTIC: + call pargstr ("Galactic") + call pargstr ("") + case CTYPE_SUPERGALACTIC: + call pargstr ("SuperGalactic") + call pargstr ("") + default: + call pargstr ("Linear") + call pargstr ("") + } + + call fprintf (fd, " Ra/Dec axes: %d/%d") + call pargi (sk_stati (co, S_PLNGAX)) + call pargi (sk_stati (co, S_PLATAX)) + call fprintf (fd, " Dimensions: %d x %d\n\n") + call pargi (IM_LEN(im,1)) + call pargi (IM_LEN(im,2)) + + call fprintf (fd, + " Center Pos: %3s: %-12H %3s: %-12h\n") + if (ctype == CTYPE_EQUATORIAL) + call pargstr (" RA") + else + call pargstr ("Lon") + call pargd (cval1) + if (ctype == CTYPE_EQUATORIAL) + call pargstr ("Dec") + else + call pargstr ("Lat") + call pargd (cval2) + + call fprintf (fd, + " Reference Pos: %3s: %-12H %3s: %-12h\n") + if (ctype == CTYPE_EQUATORIAL) + call pargstr (" RA") + else + call pargstr ("Lon") + call pargd (crval1) + if (ctype == CTYPE_EQUATORIAL) + call pargstr ("Dec") + else + call pargstr ("Lat") + call pargd (crval2) + + call fprintf (fd, + " Reference Pixel: X: %-9.4f Y: %-9.4f\n") + call pargd (crpix1) + call pargd (crpix2) + + call fprintf (fd, + " Plate Scale: %-8f Rot Angle: %-8f\n") + call pargr (IMG_SCALE(img)) + call pargr (IMG_ROT(img)) + + call fprintf (fd, + " Equinox: %s%8f Epoch: %s%.6f\n") + switch (radecsys) { + case EQTYPE_FK5, EQTYPE_ICRS: + call pargstr ("J") ; call pargd (sk_statd(co,S_EQUINOX)) + call pargstr ("J") ; call pargd (sl_epj(sk_statd(co,S_EPOCH))) + default: + if (IMG_LINEAR(img) == YES) { + call pargstr (" ") ; call pargd (INDEFD) + call pargstr (" ") ; call pargd (INDEFD) + } else { + call pargstr ("B") + call pargd (sk_statd(co,S_EQUINOX)) + call pargstr ("B") + call pargd (sl_epb(sk_statd(co,S_EPOCH))) + } + } + + call fprintf (fd, " MJD: %.6f\n") + call pargd (sk_statd(co,S_EPOCH)) + + call fprintf (fd, "}\n \n \n") + + # Close the formatted string and send the message. + call close (fd) + call wcspix_message (Memc[buf]) + + call sfree (sp) +end + + +# IMG_SEND_PIXTAB -- Send a 'pixtab' message. Format of the message is +# +# pixtab { +# { {pix} {pix} ... } # pixel table values +# { {x1} {x2} ... } # column label values +# { {y1} {y2} ... } # row label values +# { } # pixtab statistics +# } +# + +procedure img_send_pixtab (pixtab, size, x1, x2, y1, y2) + +real pixtab[ARB] #i pixtab array +int size #i pixtab size +int x1, x2, y1, y2 #i raster boundaries + +pointer sp, buf, el +int i, j, npix +real pix, sum, sum2, mean, var, stdev, x, y + +define SZ_PIXTAB (6*SZ_LINE) + +begin + call smark (sp) + call salloc (buf, SZ_PIXTAB, TY_CHAR) + call salloc (el, SZ_FNAME, TY_CHAR) + + # Begin the pixtab message. + call strcpy ("pixtab {\n{\ntable {\n", Memc[buf], SZ_PIXTAB) + + # Format the pixels into a table for presentation. Do the y-flip + # here so the pixels are in order for the List widget in the GUI. + # Accumulate the pixel statistics so we don't have to do it in the + # GUI where it's slower. + + sum = 0.0 + sum2 = 0.0 + npix = size * size + + for (i=size - 1; i >= 0; i=i-1) { + for (j=1; j <= size; j=j+1) { + pix = pixtab[(i * size) + j] + sum = sum + pix + sum2 = sum2 + (pix * pix) + + call sprintf (Memc[el], SZ_FNAME, " {%10.1f}") + call pargr (pix) + + call strcat (Memc[el], Memc[buf], SZ_PIXTAB) + } + call strcat ("\n", Memc[buf], SZ_PIXTAB) + } + call strcat ("}\n}\n", Memc[buf], SZ_PIXTAB) + + + # Do the row and column label parts of the message. + call strcat ("{", Memc[buf], SZ_PIXTAB) + for (x = x1; x <= x2; x = x + 1.) { + call sprintf (Memc[el], SZ_FNAME, " {%10.1f}") + call pargr (x) + call strcat (Memc[el], Memc[buf], SZ_PIXTAB) + } + call strcat ("}\n", Memc[buf], SZ_PIXTAB) + + call strcat ("{", Memc[buf], SZ_PIXTAB) + for (y = y2; y >= y1; y = y - 1.) { + call sprintf (Memc[el], SZ_FNAME, " {%10.1f}") + call pargr (y) + call strcat (Memc[el], Memc[buf], SZ_PIXTAB) + } + call strcat ("}\n", Memc[buf], SZ_PIXTAB) + + + # Compute the statistics for the raster. + mean = sum / real(npix) + var = (sum2 - sum * mean) / real(npix - 1) + if (var <= 0) + stdev = 0.0 + else + stdev = sqrt (var) + + call sprintf (Memc[el], SZ_FNAME, " { %10.2f %10.4f }\n") + call pargr (mean) + call pargr (stdev) + call strcat (Memc[el], Memc[buf], SZ_PIXTAB) + + + # Close the message. + call strcat ("}", Memc[buf], SZ_PIXTAB) + + if (IMG_DEBUG) { + call eprintf ("pixtab: %s\n");call pargstr(Memc[buf]) + } + + # Send the formatted message. + call wcspix_message (Memc[buf]) + + call sfree (sp) +end + + +# IMG_AMP_WCS -- Create a WCS transformation for the amplifier coordinates. + +pointer procedure img_amp_wcs (im, mw) + +pointer im #i image pointer +pointer mw #i MWCS descriptor + +pointer ct +double r[IM_MAXDIM], w[IM_MAXDIM], cd[IM_MAXDIM,IM_MAXDIM] + +double imgetd() +pointer mw_sctran() + +begin + r[1] = 0.0d0 + r[2] = 0.0d0 + w[1] = imgetd (im, "ATV1") + w[2] = imgetd (im, "ATV2") + cd[1,1] = imgetd (im, "ATM1_1") + cd[1,2] = 0.0d0 + cd[2,1] = 0.0d0 + cd[2,2] = imgetd (im, "ATM2_2") + + # Create a new named system. + call mw_newsystem (mw, "amplifier", 2) + + # Set the new Wterm for the system. + call mw_swtermd (mw, r, w, cd, 2) + + # Set up the transform. + ct = mw_sctran (mw, "logical", "amplifier", 03B) + + # Reset the default world system. + call mw_sdefwcs (mw) + + return (ct) +end + + +# IMG_DET_WCS -- Create a WCS transformation for the detector coordinates. + +pointer procedure img_det_wcs (im, mw) + +pointer im #i image pointer +pointer mw #i MWCS descriptor + +pointer ct +double r[IM_MAXDIM], w[IM_MAXDIM], cd[IM_MAXDIM,IM_MAXDIM] + +double imgetd() +pointer mw_sctran() + +begin + r[1] = 0.0d0 + r[2] = 0.0d0 + w[1] = imgetd (im, "DTV1") + w[2] = imgetd (im, "DTV2") + cd[1,1] = imgetd (im, "DTM1_1") + cd[1,2] = 0.0d0 + cd[2,1] = 0.0d0 + cd[2,2] = imgetd (im, "DTM2_2") + + # Create a new named system. + call mw_newsystem (mw, "detector", 2) + + # Set the new Wterm for the system. + call mw_swtermd (mw, r, w, cd, 2) + + # Set up the transform. + ct = mw_sctran (mw, "logical", "detector", 03B) + + # Reset the default world system. + call mw_sdefwcs (mw) + + return (ct) +end + + +# IMG_COORD_LABELS -- Get the WCS name, coord labels and format strings for +# the specified object. + +procedure img_coord_labels (cp, line, wcsname, xunits, yunits) + +pointer cp #i cache pointer +pointer line #i WCS output line +char wcsname[ARB] #o WCS name string +char xunits[ARB], yunits[ARB] #o WCS coord labels + +pointer img, co, wp +pointer sp, proj, radecstr + +int strcmp(), sk_stati(), idxstr() + +begin + img = C_DATA(cp) # initialize ptrs + co = IMG_CO(img) + wp = IMG_WP(img) + + if (SYSTEMS(wp,line) == SYS_WORLD) { + switch (sk_stati(co,S_CTYPE)) { + case CTYPE_EQUATORIAL: + call strcpy (" RA", xunits, LEN_WCSNAME) + call strcpy (" Dec", yunits, LEN_WCSNAME) + case CTYPE_ECLIPTIC: + call strcpy ("ELon", xunits, LEN_WCSNAME) + call strcpy ("ELat", yunits, LEN_WCSNAME) + case CTYPE_GALACTIC: + call strcpy ("GLon", xunits, LEN_WCSNAME) + call strcpy ("GLat", yunits, LEN_WCSNAME) + case CTYPE_SUPERGALACTIC: + call strcpy ("SLon", xunits, LEN_WCSNAME) + call strcpy ("SLat", yunits, LEN_WCSNAME) + } + } else if (SYSTEMS(wp,line) == SYS_SKY) { + call strcpy (WCSNAME(wp,line), wcsname, LEN_WCSNAME) + call strlwr (wcsname) + if (strcmp (wcsname,"ecliptic") == 0) { + call strcpy ("ELon", xunits, LEN_WCSNAME) + call strcpy ("ELat", yunits, LEN_WCSNAME) + } else if (strcmp (wcsname,"galactic") == 0) { + call strcpy ("GLon", xunits, LEN_WCSNAME) + call strcpy ("GLat", yunits, LEN_WCSNAME) + } else if (strcmp (wcsname,"supergalactic") == 0) { + call strcpy ("SLon", xunits, LEN_WCSNAME) + call strcpy ("SLat", yunits, LEN_WCSNAME) + } else { + call strcpy (" RA", xunits, LEN_WCSNAME) + call strcpy (" Dec", yunits, LEN_WCSNAME) + } + } else { + call strcpy ("X", xunits, LEN_WCSNAME) + call strcpy ("Y", yunits, LEN_WCSNAME) + } + + + # Now get the format strings. For systems other than the image + # default just use the WCS string as the name, otherwise format a + # string giving more information about the system. + if (SYSTEMS(wp,line) != SYS_WORLD) + call strcpy (WCSNAME(wp,line), wcsname, LEN_WCSNAME) + + else { + call smark (sp) + call salloc (radecstr, SZ_FNAME, TY_CHAR) + call salloc (proj, SZ_FNAME, TY_CHAR) + + call sprintf (wcsname, LEN_WCSNAME, "%s-%s-%s") + + switch (sk_stati(co,S_CTYPE)) { + case CTYPE_EQUATORIAL: call pargstr ("EQ") + case CTYPE_ECLIPTIC: call pargstr ("ECL") + case CTYPE_GALACTIC: call pargstr ("GAL") + case CTYPE_SUPERGALACTIC: call pargstr ("SGAL") + default: call pargstr ("UNKN") + } + + if (sk_stati(co,S_CTYPE) == CTYPE_EQUATORIAL) { + if (idxstr(sk_stati(co,S_RADECSYS), Memc[radecstr], + SZ_FNAME, EQTYPE_LIST) <= 0) + call strcpy ("FK5", Memc[radecstr], SZ_FNAME) + call strupr (Memc[radecstr]) + call pargstr (Memc[radecstr]) + } else { + if (sk_stati(co,S_CTYPE) == CTYPE_SUPERGALACTIC) + call pargstr ("-") + else + call pargstr ("--") + } + + if (idxstr(sk_stati(co,S_WTYPE), Memc[proj], SZ_FNAME, + WTYPE_LIST) <= 0) + call strcpy ("linear", Memc[proj], SZ_FNAME) + call strupr (Memc[proj]) + call pargstr (Memc[proj]) + + call sfree (sp) + } + + # Now fix up the WCS system name. + if (strcmp (wcsname, "fk4") == 0 || + strcmp (wcsname, "fk5") == 0 || + strcmp (wcsname, "icrs") == 0 || + strcmp (wcsname, "gappt") == 0 || + strcmp (wcsname, "fk4-no-e") == 0) { + call strupr (wcsname) + + } else if (IS_LOWER(wcsname[1])) + wcsname[1] = TO_UPPER(wcsname[1]) +end + + +# IMG_COORD_FMT -- Format the coordinate strings. + +procedure img_coord_fmt (cp, line, xval, yval, xc, yc) + +pointer cp #i object cache pointer +int line #i output line number +double xval, yval #i input coords +char xc[ARB], yc[ARB] #o formatted coord strings + +pointer img, co, wp +char xfmt[LEN_WCSNAME], yfmt[LEN_WCSNAME] +int ctype + +int sk_stati() +bool streq() + +begin + img = C_DATA(cp) # initialize ptrs + co = IMG_CO(img) + wp = IMG_WP(img) + + + ctype = sk_stati (co, S_CTYPE) + + # Convert coords to the requested format. + if (FORMATS(wp,line) == FMT_DEFAULT) { + if (IMG_MW(img) == NULL) { + call strcpy ("%10.2f", xfmt, LEN_WCSNAME) + call strcpy ("%10.2f", yfmt, LEN_WCSNAME) + } else { + if (SYSTEMS(wp,line) == SYS_WORLD || + SYSTEMS(wp,line) == SYS_SKY) { + + if (streq(WCSNAME(wp,line),"ecliptic") || + streq(WCSNAME(wp,line),"galactic") || + streq(WCSNAME(wp,line),"supergalactic")) + call strcpy ("%h", xfmt, LEN_WCSNAME) + else { + if (sk_stati(co, S_CTYPE) == CTYPE_EQUATORIAL) + call strcpy ("%.2H", xfmt, LEN_WCSNAME) + else + call strcpy ("%.2h", xfmt, LEN_WCSNAME) + } + call strcpy ("%.1h", yfmt, LEN_WCSNAME) + } else { + call strcpy ("%10.2f", xfmt, LEN_WCSNAME) + call strcpy ("%10.2f", yfmt, LEN_WCSNAME) + } + } + + } else if (FORMATS(wp,line) == FMT_HMS) { + if (sk_stati(co, S_CTYPE) == CTYPE_EQUATORIAL) + call strcpy ("%.2H", xfmt, LEN_WCSNAME) + else + call strcpy ("%.1h", xfmt, LEN_WCSNAME) + call strcpy ("%h", yfmt, LEN_WCSNAME) + } else { + call strcpy ("%10.2f", xfmt, LEN_WCSNAME) + call strcpy ("%10.2f", yfmt, LEN_WCSNAME) + } + + # Convert the value to the requested format + call sprintf (xc, LEN_WCSNAME, xfmt) + if (FORMATS(wp,line) != FMT_RAD) + call pargd (xval) + else + call pargd (DEGTORAD(xval)) + + call sprintf (yc, LEN_WCSNAME, yfmt) + if (FORMATS(wp,line) != FMT_RAD) + call pargd (yval) + else + call pargd (DEGTORAD(yval)) +end + + +# IMG_GET_COORD -- Given an x,y position in the image return the coordinate in +# the given system. + +procedure img_get_coord (img, x, y, system, wcsname, wx, wy) + +pointer img #i IMG struct pointer +double x, y #i input image position +int system #i coordinate system requested +char wcsname[ARB] #i desired WCS name +double wx, wy #o output coordinates + +double ox, oy, tmp +real epoch +pointer im, co, nco +char buf[SZ_LINE] +int stat + +real imgetr() +int imaccf(), sk_stati(), sk_decwstr() +bool streq() + +errchk imgetr + +begin + im = IMG_IM(img) + co = IMG_CO(img) + + wx = x # fallback values + wy = y + + switch (system) { + case SYS_NONE: + wx = x + wy = y + case SYS_DISPLAY: + call img_ltov (im, x, y, wx, wy) + #wx = x + #wy = y + case SYS_PHYSICAL: + if (IMG_CTP(img) != NULL) + call mw_c2trand (IMG_CTP(img), x, y, wx, wy) + case SYS_WORLD: + if (IMG_CTW(img) != NULL) { + call mw_c2trand (IMG_CTW(img), x, y, wx, wy) + + # Check for transposed image. + if (sk_stati(co,S_PLATAX) < sk_stati(co,S_PLNGAX)) { + tmp = wx + wx = wy + wy = tmp + } + } + case SYS_AMP: + if (IMG_CTA(img) != NULL) + call mw_c2trand (IMG_CTA(img), x, y, wx, wy) + case SYS_CCD: + if (IMG_CTD(img) != NULL) + call mw_c2trand (IMG_CTD(img), x, y, wx, wy) + case SYS_DETECTOR: + if (IMG_CTD(img) != NULL) + call mw_c2trand (IMG_CTD(img), x, y, wx, wy) + case SYS_SKY: + # Note Ecliptic/GAPPT coords need an epoch value. + if (imaccf (im, "EPOCH") == YES) { + epoch = imgetr (im, "EPOCH") + if (epoch == 0.0 || IS_INDEFR(epoch)) + epoch = 1950.0 + } else + epoch = 1950.0 + + if (streq (wcsname, "ecliptic") || streq (wcsname, "gappt")) { + call sprintf (buf, SZ_LINE, "%s %.1f") + if (streq (wcsname, "gappt")) + call pargstr ("apparent") + else + call pargstr (wcsname) + call pargr (epoch) + } else { + call sprintf (buf, SZ_LINE, "%s") + if (streq(wcsname,"gappt")) + call pargstr ("apparent") + else if (streq(wcsname,"fk4-no-e")) + call pargstr ("noefk4") + else + call pargstr (wcsname) + } + + stat = sk_decwstr (buf, nco, co) + if (stat != ERR) { + if (IMG_CTW(img) != NULL) + call mw_c2trand (IMG_CTW(img), x, y, ox, oy) + call sk_lltran (co, nco, DEGTORAD(ox), DEGTORAD(oy), + INDEFD, INDEFD, 0.0d0, 0.0d0, wx, wy) + if (sk_stati(co,S_PLATAX) < sk_stati(co,S_PLNGAX)) { + wx = RADTODEG(wy) # transposed image + wy = RADTODEG(wx) + } else { + wx = RADTODEG(wx) # regular image + wy = RADTODEG(wy) + } + } else { + wx = x + wy = y + } + case SYS_OTHER: + ; # TBD + + default: # default coords + wx = x + wy = y + } +end + + +# IMG_LTOV -- Convert coordinate from the logical coordinate system to the +# output coordinate system. + +procedure img_ltov (im, xin, yin, xout, yout) + +pointer im # the input image descriptor +double xin # the input x coordinate +double yin # the input y coordinate +double xout # the output x coordinate +double yout # the output y coordinate + +int index1, index2 + +begin + index1 = IM_VMAP(im,1) + index2 = IM_VMAP(im,2) + + xout = xin * IM_VSTEP(im,index1) + IM_VOFF(im,index1) + yout = yin * IM_VSTEP(im,index2) + IM_VOFF(im,index2) +end + + +# IMG_VTOL -- Convert coordinate from the tv coordinate system to the +# logical coordinate system. + +procedure img_vtol (im, xin, yin, xout, yout) + +pointer im # the input image descriptor +double xin # the input x coordinate +double yin # the input y coordinate +double xout # the output x coordinate +double yout # the output y coordinate + +int index1, index2 + +begin + index1 = IM_VMAP(im,1) + index2 = IM_VMAP(im,2) + + xout = (xin - IM_VOFF(im,index1)) / IM_VSTEP(im,index1) + yout = (yin - IM_VOFF(im,index2)) / IM_VSTEP(im,index2) +end diff --git a/vendor/x11iraf/ximtool/clients/wcspix/wcimage.x.bak b/vendor/x11iraf/ximtool/clients/wcspix/wcimage.x.bak new file mode 100644 index 00000000..87a12a39 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients/wcspix/wcimage.x.bak @@ -0,0 +1,1515 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include +include +include +include +include +include +include "wcspix.h" + + +# Image class data. +define LEN_IMGDATA 15 +define IMG_WP Memi[$1 ] # wcspix back-pointer +define IMG_IM Memi[$1+1] # image pointer +define IMG_BPM Memi[$1+2] # bad pixel mask pointer +define IMG_MW Memi[$1+3] # image wcs pointer +define IMG_CO Memi[$1+4] # skywcs transform pointer +define IMG_CTW Memi[$1+5] # mwcs log->world transform ptr +define IMG_CTP Memi[$1+6] # mwcs log->phys transform ptr +define IMG_CTA Memi[$1+7] # mwcs log->amplifier transform +define IMG_CTD Memi[$1+8] # mwcs log->detector transform +define IMG_ROT Memr[$1+9] # rotation angle +define IMG_SCALE Memr[$1+10] # plate scale +define IMG_LINEAR Memi[$1+11] # linear coords + + +define IMG_DEBUG FALSE + + +# IMG_INIT -- Initialize the object structure. + +procedure img_init (cp, wp) + +pointer cp #i cache pointer +pointer wp #i WCSPIX structure + +pointer img # data pointer + +begin + if (IMG_DEBUG) call printf ("img_init: \n") + + # Allocate the image data structure if not previously allocated. + if (C_DATA(cp) == NULL) { + iferr (call calloc (C_DATA(cp), LEN_IMGDATA, TY_STRUCT)) + return + } + + img = C_DATA(cp) + IMG_WP(img) = wp + IMG_IM(img) = NULL + IMG_BPM(img) = NULL + IMG_MW(img) = NULL + IMG_CO(img) = NULL + IMG_CTW(img) = NULL + IMG_CTP(img) = NULL + IMG_CTA(img) = NULL + IMG_CTD(img) = NULL + IMG_ROT(img) = 0.0 + IMG_SCALE(img) = 0.0 + IMG_LINEAR(img) = YES +end + + +# IMG_CACHE -- Cache an image in the object cache. + +procedure img_cache (cp, objid, regid, ref) + +pointer cp #i cache pointer +int objid #i object id +int regid #i region id +char ref[ARB] #i object reference + +pointer img, im, wp, co +int stat, i1, i2 +char alert[SZ_LINE] + +pointer immap(), ds_pmmap(), mw_sctran() +pointer img_amp_wcs(), img_det_wcs() +int imaccf(), sk_decim() + +errchk immap, ds_pmmap, mw_sctran, sk_decim, sk_setd + +begin + if (IMG_DEBUG) call printf ("img_cache: \n") + + # Now map the image and WCS. + img = C_DATA(cp) + wp = IMG_WP(img) + + iferr (IMG_IM(img) = immap (ref, READ_ONLY, 0)) { + # Send alert to the GUI. + call sprintf (alert, SZ_FNAME, "Unable to cache\n%s") + call pargstr (ref) + call ism_alert (alert, "", "") + return + } + im = IMG_IM(img) + + IMG_CO(img) = NULL + IMG_CTW(img) = NULL + IMG_CTP(img) = NULL + IMG_CTA(img) = NULL + IMG_CTD(img) = NULL + iferr { + stat = sk_decim (IMG_IM(img), "world", IMG_MW(img), IMG_CO(img)) + if (IMG_DEBUG) { + call eprintf ("img_cache - decim: stat=%d mw=%d co=%d \n") + call pargi(stat);call pargi(IMG_MW(img)) + call pargi(IMG_CO(img)); + } + if (stat == ERR || IMG_MW(img) == NULL) { + IMG_LINEAR(img) = YES + + co = IMG_CO(img) + i1 = IM_VMAP(im,1) + i2 = IM_VMAP(im,2) + call sk_setd (co, S_VXOFF, double(IM_VOFF(im,i1))) + call sk_setd (co, S_VYOFF, double(IM_VOFF(im,i2))) + call sk_setd (co, S_VXSTEP, double(IM_VSTEP(im,i1))) + call sk_setd (co, S_VYSTEP, double(IM_VSTEP(im,i2))) + + IMG_MW(img) = NULL + IMG_LINEAR(img) = YES + } + + if (IMG_MW(img) != NULL) { + IMG_CTW(img) = mw_sctran (IMG_MW(img), "logical", "world", 03B) + IMG_CTP(img) = mw_sctran (IMG_MW(img), "logical", "physical", + 03B) + + # Get the amplifier transformation values if present. + if (imaccf(im,"ATM1_1") == YES && + imaccf(im,"ATM2_2") == YES && + imaccf(im,"ATV1") == YES && + imaccf(im,"ATV2") == YES) + IMG_CTA(img) = img_amp_wcs (im, IMG_MW(img)) + + if (imaccf(im,"DTM1_1") == YES && + imaccf(im,"DTM2_2") == YES && + imaccf(im,"DTV1") == YES && + imaccf(im,"DTV2") == YES) + IMG_CTD(img) = img_det_wcs (im, IMG_MW(img)) + } + + } then { + # Send alert to the GUI. + call sprintf (alert, SZ_FNAME, "Unable to decode image WCS\n%s") + call pargstr (ref) + call ism_alert (alert, "", "") + IMG_LINEAR(img) = YES + } + + + # See if we can find a bad pixel mask. + IMG_BPM(img) = NULL + if (WP_BPM(wp) == YES) { + iferr (IMG_BPM(img) = ds_pmmap ("BPM", IMG_IM(img))) + IMG_BPM(img) = NULL + } + + C_OBJID(cp) = objid + C_REGID(cp) = regid + C_NREF(cp) = C_NREF(cp) + 1 + call strcpy (ref, C_REF(cp), 128) +end + + +# IMG_UNCACHE -- Uncache an image in the object cache. + +procedure img_uncache (cp, id) + +pointer cp #i cache pointer +int id #i image id + +pointer img + +begin + if (IMG_DEBUG) call printf ("img_uncache: \n") + + C_OBJID(cp) = NULL + C_NREF(cp) = 0 + call strcpy ("", C_REF(cp), SZ_FNAME) + + img = C_DATA(cp) + if (IMG_MW(img) != NULL) + call mw_close (IMG_MW(img)) + if (IMG_BPM(img) != NULL) + call imunmap (IMG_BPM(img)) + if (IMG_IM(img) != NULL) + call imunmap (IMG_IM(img)) + + IMG_IM(img) = NULL + IMG_BPM(img) = NULL + IMG_MW(img) = NULL + IMG_CTW(img) = NULL + IMG_CTP(img) = NULL + IMG_CTA(img) = NULL + IMG_CTD(img) = NULL + IMG_CO(img) = NULL + IMG_ROT(img) = 0.0 + IMG_SCALE(img) = 0.0 + IMG_LINEAR(img) = NO + + call mfree (C_DATA(cp), TY_STRUCT) + C_DATA(cp) = NULL +end + + +# IMG_WCSTRAN -- Translate object source (x,y) coordinates to the +# desired output WCSs. Message is returned as something like: +# +# set value { +# { object } { region } +# { pixval [] } +# { bpm } +# { coord [ ] } +# { coord [ ] } +# : +# } + + +procedure img_wcstran (cp, id, x, y) + +pointer cp #i cache pointer +int id #i image id +real x, y #i source coords + +pointer img, im, wp, co +double dx, dy, wx, wy +real rx, ry, pixval +int i, bpm + +# Use static storage to avoid allocation overhead. +char buf[SZ_LINE] +char msg[SZ_LINE], wcs[LEN_WCSNAME], xc[LEN_WCSNAME], yc[LEN_WCSNAME] +char xunits[LEN_WCSNAME], yunits[LEN_WCSNAME] + +double sk_statd() + +begin + if (IMG_DEBUG) call printf ("img_wcstran: \n") + + img = C_DATA(cp) # initialize + co = IMG_CO(img) + wp = IMG_WP(img) + im = IMG_IM(img) + + # Get the translation to the image section. + dx = (double(x) - sk_statd(co,S_VXOFF)) / sk_statd(co,S_VXSTEP) + dy = (double(y) - sk_statd(co,S_VYOFF)) / sk_statd(co,S_VYSTEP) + rx = dx + ry = dy + + # Read the pixel data. + call img_get_data (cp, id, rx, ry, pixval, bpm) + + # Begin formatting the message. + call aclrc (msg, SZ_LINE) + call sprintf (msg, SZ_LINE, "wcstran { object %d } { region %d } ") + call pargi (C_OBJID(cp)) + call pargi (C_REGID(cp)) + + call sprintf (buf, SZ_LINE, "{ pixval %9.9g } { bpm %d }\n") + call pargr (pixval) + call pargi (bpm) + call strcat (buf, msg, SZ_LINE) + + # Now loop over the requested systems and generate a coordinate + # for each. + for (i=1; i <= MAX_WCSLINES; i=i+1) { + + # Get the coordinate value. + call img_get_coord (img, dx, dy, SYSTEMS(wp,i), WCSNAME(wp,i), + wx, wy) + + # Get the system name, labels, and formats strings for the WCS. + call img_coord_labels (cp, i, wcs, xunits, yunits) + + # Format the values as requested. + call img_coord_fmt (cp, i, wx, wy, xc, yc) + + # Format the coord buffer and append it to the message. + call sprintf (buf, SZ_LINE, + "{coord {%9s} {%12s} {%12s} {%4s} {%4s}}\n") + call pargstr (wcs) + call pargstr (xc) + call pargstr (yc) + call pargstr (xunits) + call pargstr (yunits) + call strcat (buf, msg, SZ_LINE) + } + + # Now send the completed message. + call wcspix_message (msg); +end + + +# IMG_WCSLIST -- List the WCSs available for the given image. + +procedure img_wcslist (cp, id) + +pointer cp #i cache pointer +int id #i image id + +pointer img, im, mw +char msg[SZ_LINE] + +begin + if (IMG_DEBUG) call printf ("img_wcslist: \n") + + img = C_DATA(cp) # initialize + mw = IMG_MW(img) + im = IMG_IM(img) + + call strcpy ("wcslist {None Display Logical World Physical line ", + msg, SZ_LINE) + + # See if we can do amplifier/detector coords by checking for ATM/ATV + # and DTM/DTV keywords. + + if (IMG_CTA(img) != NULL) + call strcat (" Amplifier ", msg, SZ_LINE) + if (IMG_CTD(img) != NULL) + call strcat (" Detector ", msg, SZ_LINE) + if (IMG_CTA(img) != NULL || IMG_CTD(img) != NULL) + call strcat (" CCD ", msg, SZ_LINE) + + # If we have a MWCS pointer list the sky projections. + if (mw != NULL) { + call strcat (" line ", msg, SZ_LINE) + call strcat (SKYPROJ, msg, SZ_LINE) + } + + # Close the message. + call strcat ("}", msg, SZ_LINE) + + call wcspix_message (msg) +end + + +# IMG_GET_DATA -- Get data from the image. + +procedure img_get_data (cp, id, x, y, pixval, bpm_pix) + +pointer cp #i cache pointer +int id #i image id +real x, y #i source coords +real pixval #o central pixel value +int bpm_pix #o bad pixel mask value + +pointer img, wp, im, bpm, pix, sp, msg, buf +int nl, nc, ix, iy, s2 +int size, x1, x2, y1, y2 + +long clktime() +pointer imgs2r(), imgs2i(), ds_pmmap() +errchk ds_pmmap + +begin + + img = C_DATA(cp) + wp = IMG_WP(img) + im = IMG_IM(img) + bpm = IMG_BPM(img) + nc = IM_LEN(im,1) + nl = IM_LEN(im,2) +# size = WP_PTABSZ(wp) + size = min(min(nc,nl),WP_PTABSZ(wp)) + + if (IMG_DEBUG) { + call printf ("img_get_data: \n") + call eprintf ("\tx: %g y: %g nc: %d nl: %d\n") + call pargr(x); call pargr(y); call pargi(nc); call pargi(nl) + } + + # Sanity check on the cursor image position. + if (x < 0.0 || y < 0.0 || x > (nc+0.5) || y > (nl+0.5)) + return + + # Bounds checking. Rather than deal with out of bounds pixels we'll + # adjust the center pixel so we get the same size raster up to each + # boundary. + + ix = int (x + 0.5) ; iy = int (y + 0.5) + ix = min (ix, (nc-(size/2)-1)) ; iy = min (iy, (nl-(size/2)-1)) + ix = max (size/2+1, ix) ; iy = max (size/2+1, iy) + + # Compute the box offset given the center and size. + x1 = ix - size / 2 + 0.5 + x2 = ix + size / 2 + 0.5 + y1 = iy - size / 2 + 0.5 + y2 = iy + size / 2 + 0.5 + + if (IMG_DEBUG) { + call printf ("img_get_data: \n") + call eprintf ("\tix: %d iy: %g size: %d\n") + call pargi(ix); call pargi(iy); call pargi(size) + call eprintf ("\tx1: %d y1: %d x2: %d y2: %d\n") + call pargi(x1); call pargi(y1); + call pargi(x2); call pargi(y2); + } + + x1 = max (1, x1) + x2 = min (nc, x2) + y1 = max (1, y1) + y2 = min (nl, y2) + + if (IMG_DEBUG) { + call eprintf ("\tx1: %d y1: %d x2: %d y2: %d\n") + call pargi(x1); call pargi(y1); + call pargi(x2); call pargi(y2); + } + + # Get the image pixels + pix = imgs2r (im, int(x1), int(x2), int(y1), int(y2)) + + if (WP_BPM(wp) == YES) { + if (bpm != NULL) { + bpm_pix = Memi[imgs2i (bpm, ix, ix, iy, iy)] + } else { + # See if we can find a bad pixel mask. The option is enabled + # but we haven't mappend the mask yet. + + # Log the event. + call smark (sp) + call salloc (msg, SZ_LINE, TY_CHAR) + call salloc (buf, SZ_LINE, TY_CHAR) + call wp_cnvdate (clktime(0), Memc[buf], SZ_DATE) + call sprintf (Memc[msg], SZ_LINE, + "info { %s: WCSPIX BPM map objid=%3d %s}\n") + call pargstr (Memc[buf]) + call pargi (C_OBJID(cp)) + call pargstr (C_REF(cp)) + call ism_message ("ism_msg", Memc[msg]) + + iferr (IMG_BPM(img) = ds_pmmap ("BPM", im)) { + IMG_BPM(img) = NULL + bpm_pix = 0 + + # Send alert to the GUI. + call sprintf (Memc[buf], SZ_FNAME, + "Unable to map BPM image for\n%s") + call pargstr (C_REF(cp)) + call ism_alert (Memc[buf], "", "") + } else + bpm_pix = Memi[imgs2i (IMG_BPM(img), ix, ix, iy, iy)] + + call sfree (sp) + } + } else + bpm_pix = 0 + + # See if we're near an edge... + s2 = size / 2 + if (int(x)(nl-s2-1) || int(y)(nc-s2-1)) { + # Compute the image pixel associated with the requested coords. + ix = int (x + 0.5) + iy = int (y + 0.5) + pixval = Memr[imgs2r(im, ix, ix, iy, iy)] + } else { + pixval = Memr[pix + ((size/2)*size) + (size/2)] + } + + # Send the pixel table. + if (WP_PTABSZ(wp) > 1) + call img_send_pixtab (Memr[pix], WP_PTABSZ(wp), x1, x2, y1, y2) + + if (IMG_DEBUG) { + call printf ("img_get_data: pixval=%g\n") ; call pargr (pixval) + } +end + + +# IMG_OBJINFO -- Get header information from the image. + +procedure img_objinfo (cp, id, template) + +pointer cp #i cache pointer +int id #i image id +char template[ARB] #i keyword template + +pointer im, img + +define WCS_TEMPLATE "WCSDIM,CTYPE*,CRPIX*,CRVAL*,CD*,CROTA2,LTV*,LTM*,WSV*,WAT*,RA*,DEC*,EQUINOX,EPOCH,MJD*,DATE-OBS" + +begin + if (IMG_DEBUG) call printf ("img_objinfo: \n") + + # Send the full header (or keyword filtered header), only the WCS + # keywords, and a plain-text explanation of the WCS. + + img = C_DATA(cp) + im = IMG_IM(img) + + call img_send_header (im, "imghdr", template) + call img_send_header (im, "wcshdr", WCS_TEMPLATE) + call img_send_wcsinfo (im, cp) + call img_send_compass (im, cp) +end + + + +#============================================================================== + +# IMG_SEND_HEADER -- Send an image header to the named GUI object. Keywords +# are filtered according to a specified template + +procedure img_send_header (im, object, template) + +pointer im #i image descriptor +char object[ARB] #i object for the message +char template[ARB] #i keyword template + +pointer sp, hdr, lbuf, line, field, keyw, dict +pointer ip, lp, list +int nlines, in, out, i, hdr_size +bool keyw_filter + +int stropen(), getline(), stridx(), imgnfn(), strdic() +pointer imofnlu() +bool streq() +errchk stropen, getline, putci, putline, imgnfn, imofnlu, strdic + +define USER_AREA Memc[($1+IMU-1)*SZ_STRUCT + 1] +define SZ_KEYW 8 + +begin + hdr_size = (LEN_IMDES + IM_LENHDRMEM(im) - IMU) * SZ_STRUCT - 1 + hdr_size = hdr_size + SZ_LINE + + call smark (sp) + call salloc (hdr, hdr_size, TY_CHAR) + call salloc (dict, hdr_size, TY_CHAR) + call salloc (field, SZ_LINE, TY_CHAR) + call salloc (lbuf, SZ_LINE, TY_CHAR) + call salloc (line, SZ_LINE, TY_CHAR) + call salloc (keyw, SZ_KEYW, TY_CHAR) + + in = stropen (USER_AREA(im), hdr_size, READ_ONLY) + out = stropen (Memc[hdr], hdr_size, WRITE_ONLY) + call fprintf (out, "%s {") + call pargstr (object) + + # Build up a dictionary of header keywords based on the template. + keyw_filter = (!streq (template, "*")) + if (keyw_filter) { + list = imofnlu (im, template) + call strcpy ("|", Memc[dict], hdr_size) + while (imgnfn (list, Memc[field], SZ_FNAME) != EOF) { + call strcat (Memc[field], Memc[dict], hdr_size) + call strcat ("|", Memc[dict], hdr_size) + } + call imcfnl (list) + } + + + # Copy header records to the output, stripping any trailing + # whitespace and clipping at the right margin. We also filter + # against the keyword dictionary found above. + + nlines = 0 + while (getline (in, Memc[lbuf]) != EOF) { + + call aclrc (Memc[line], SZ_LINE) + + # Escape any brackets passed to the Tcl. + ip = lbuf + lp = line + while (Memc[ip] != EOS && Memc[ip] != '\n') { + if (stridx (Memc[ip], "[{") > 0) { + Memc[lp] = '\\' + lp = lp + 1 + } + Memc[lp] = Memc[ip] + ip = ip + 1 + lp = lp + 1 + } + Memc[lp] = '\n' + Memc[lp+1] = EOS + + # See whether the line matches a keyword we want to output. + if (keyw_filter) { + for (i=0; i < SZ_KEYW && !IS_WHITE(Memc[line+i]); i=i+1) + Memc[keyw+i] = Memc[line+i] + Memc[keyw+i] = '\0' + + # If not in the dictionary skip to the next line. + if (strdic (Memc[keyw], Memc[keyw], SZ_KEYW, Memc[dict]) == 0) + next + } + + call putci (out, ' ') + call putline (out, Memc[line]) + + # Send the header in small chunks so we don't overflow the + # message buffer. + nlines = nlines + 1 + if (mod(nlines,10) == 0) { + call fprintf (out, "}") + call close (out) + call wcspix_message (Memc[hdr]); + call aclrc (Memc[hdr], hdr_size) + out = stropen (Memc[hdr], hdr_size, WRITE_ONLY) + call fprintf (out, "%s {") + call pargstr (object) + } + } + call fprintf (out, "}") + + call close (in) + call close (out) + + # Send the final message. + call wcspix_message (Memc[hdr]) + + # Pad a few lines for the GUI + call sprintf (Memc[hdr], SZ_LINE, "%d { \n\n\n }") + call pargstr (object) + call wcspix_message (Memc[hdr]) + + call sfree (sp) +end + + +# IMG_SEND_COMPASS -- Send information about the image WCS in a plain-english +# string. + +procedure img_send_compass (im, cp) + +pointer im #i image descriptor +pointer cp #i cache element pointer + +pointer sp, buf, img, co, mw +double cx, cy, cx1, cy1, dx, dy, x1, y1 +double cosa, sina, angle +double r[IM_MAXDIM], w[IM_MAXDIM], cd[IM_MAXDIM,IM_MAXDIM] +int i, j, comp_x, comp_y +long axis[IM_MAXDIM], lv[IM_MAXDIM], pv1[IM_MAXDIM], pv2[IM_MAXDIM] +bool fp_equalr() + +real length, north[2], east[2] + +int mw_stati(), sk_stati() + +begin + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + call aclrc (Memc[buf], SZ_LINE) + + # Get the data pointer. + img = C_DATA(cp) + co = IMG_CO(img) + + # Get world coords at the image corners. + if (IMG_CTW(img) != NULL) { + + if (fp_equalr(IMG_ROT(img),0.0)) + angle = -IMG_ROT(img) + else if (IMG_ROT(img) > 0.0) + angle = -IMG_ROT(img) + else + angle = IMG_ROT(img) + 360.0 + cosa = cos (DEGTORAD(angle)) + sina = sin (DEGTORAD(angle)) +call eprintf ("compass: angle = %g sina=%g cosa=%g\n") +call pargd(angle); call pargd(sina); call pargd(cosa) + + # Image center position + cx = IM_LEN(im,1) / 2.0d0 + cy = IM_LEN(im,2) / 2.0d0 + call mw_c2trand (IMG_CTW(img), cx, cy, cx1, cy1) + + # Extend a unit vector up from the center assuming it's North + # and rotate it by the wcs angle. + dx = cx + ( 10.0 * sina) + dy = cy + ( 10.0 * cosa) + call mw_c2trand (IMG_CTW(img), dx, dy, x1, y1) + + # Check new point Y value relative to the center position. + if (y1 >= cy1) + comp_y = 1 # North is up + else + comp_y = -1 # North is down +call eprintf ("compass: y1=%g cy1=%g \n");call pargd(y1);call pargd(cy1) + + # Extend a unit vector left from the center assuming it's East + # and rotate it by the wcs angle. + dx = cx + (-10.0 * cosa) + dy = cy + ( 10.0 * sina) + call mw_c2trand (IMG_CTW(img), dx, dy, x1, y1) + + # Check new point X value relative to the center position. + if (x1 >= cx1) + comp_x = 1 # East is left and we have a WCS + else + comp_x = -1 # East is right +call eprintf ("compass: x1=%g cx1=%g \n");call pargd(x1);call pargd(cx1) + +#------------------------------ +# New compass algorithm +#------------------------------ + + # Get the CD matrix for the image. + mw = IMG_MW(img) + call wcs_gfterm (mw, r, w, cd, mw_stati(mw, MW_NPHYSDIM)) + call img_cvectors (cd, 1.0, north, east) + + if (y1 >= 0.0) + comp_y = 1 # North is up + else + comp_y = -1 # North is down + + if (x1 >= 0.0) + comp_x = 1 # East is left + else + comp_x = -1 # East is right + + } else { + # Determine the logical to physical mapping by evaluating two + # points and determining the axis reduction if any. pv1 will be + # the offset and pv2-pv1 will be the scale. + + lv[1] = 0; lv[2] = 0; call imaplv (im, lv, pv1, 2) + lv[1] = 1; lv[2] = 1; call imaplv (im, lv, pv2, 2) + + i = 1 + axis[1] = 1; axis[2] = 2 + do j = 1, IM_MAXDIM { + if (pv1[j] != pv2[j]) { + axis[i] = j + i = i + 1 + } + } + comp_x = - (pv2[axis[1]] - pv1[axis[1]]) + comp_y = (pv2[axis[2]] - pv1[axis[2]]) + } + + call sprintf (Memc[buf], SZ_LINE, "compass %d %g %d %d %d %s\0") + call pargi (C_OBJID(cp)) + call pargr (IMG_ROT(img)) + call pargi (comp_x) + call pargi (comp_y) + if (sk_stati(co,S_PLATAX) < sk_stati(co,S_PLNGAX)) + call pargi (1) # transposed image + else + call pargi (0) + if (IMG_MW(img) != NULL) + call pargstr ("E N") + else + call pargstr ("X Y") +call eprintf ("msg: '%s'\n");call pargstr(Memc[buf]) + + call wcspix_message (Memc[buf]) + call sfree (sp) +end + + +# IMG_CVECTORS -- Get north and east vectors for the compass + +procedure img_cvectors (cd, length, north, east) + +double cd[2,2] #i CD matrix +real length #i length of vectors +real north[2] #o vector pointing north +real east[2] #o vector pointing east + +double d # determinant of CD matrix +double x, y # scratch for vector components +double l # length of a vector + +begin + d = cd[1,1] * cd[2,2] - cd[1,2] * cd[2,1] + if (d == 0.d0) + call error (1, "CD matrix is singular") + + # North. + x = -cd[1,2] / d + y = cd[1,1] / d + + # Normalize by the length and copy to output. + l = sqrt (x**2 + y**2) + north[1] = x * length / l + north[2] = y * length / l + + # East. + x = cd[2,2] / d + y = -cd[2,1] / d + l = sqrt (x**2 + y**2) + east[1] = x * length / l + east[2] = y * length / l + +call eprintf ("new: north (%g,%g) east (%g,%g)\n") +call pargr(north[1]);call pargr(north[2]) +call pargr(east[1]) ;call pargr(east[2]) +end + + + +# IMG_SEND_WCSINFO -- Send information about the image WCS in a plain-english +# string. + +procedure img_send_wcsinfo (im, cp) + +pointer im #i image descriptor +pointer cp #i cache element pointer + +pointer sp, co, img, mw +pointer buf, proj, radecstr +int fd, radecsys, ctype, wtype, ndim +double crpix1, crpix2, crval1, crval2, cval1, cval2 +double xscale, yscale, xrot, yrot +double r[IM_MAXDIM], w[IM_MAXDIM], cd[IM_MAXDIM,IM_MAXDIM], + +int idxstr(), sk_stati(), stropen(), mw_stati() +double sk_statd(), sl_epj(), sl_epb() +bool fp_equald() + +errchk stropen + +begin + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + call salloc (proj, SZ_FNAME, TY_CHAR) + call salloc (radecstr, SZ_FNAME, TY_CHAR) + + # Open a string on a file. + fd = stropen (Memc[buf], SZ_LINE, WRITE_ONLY) + + # Get the data pointer. + img = C_DATA(cp) + + # Get the coordinate transform descriptor. + co = IMG_CO(img) + radecsys = sk_stati (co, S_RADECSYS) + ctype = sk_stati (co, S_CTYPE) + wtype = sk_stati (co, S_WTYPE) + + mw = IMG_MW(img) + if (mw != NULL) { + # Now get the mwcs Rterm (CRPIXi), Wterm (CRVALi), and CD matrix. + ndim = mw_stati (mw, MW_NPHYSDIM) + call wcs_gfterm (mw, r, w, cd, ndim) + crpix1 = r[1] + crpix2 = r[2] + crval1 = w[1] + crval2 = w[2] + + xscale = sqrt (cd[1,1]**2 + cd[2,1]**2) * 3600.0d0 + yscale = sqrt (cd[1,2]**2 + cd[2,2]**2) * 3600.0d0 + xrot = 0.0 + yrot = 0.0 + if (!fp_equald (cd[1,1], 0.0d0)) + xrot = DRADTODEG(atan ( cd[2,1] / cd[1,1])) + if (!fp_equald (cd[2,2], 0.0d0)) + yrot = DRADTODEG(atan (-cd[1,2] / cd[2,2])) + } else { + ndim = 2 + xscale = 1.0 + yscale = 1.0 + xrot = 0.0 + yrot = 0.0 + } + + if (IMG_DEBUG) { + call printf("WCS Info:\n=========\n") + call printf("R term: %g %g\n"); call pargd(r[1]); call pargd(r[2]) + call printf("W term: %g %g\n"); call pargd(w[1]); call pargd(w[2]) + call printf(" cd: %g %g\n %g %g\n") + call pargd(cd[1,1]); call pargd(cd[1,2]) + call pargd(cd[2,1]); call pargd(cd[2,2]) + call printf(" scale: %g %g\n");call pargd(xscale);call pargd(yscale) + call printf(" rot: %g %g\n");call pargd(xrot);call pargd(yrot) + } + + IMG_SCALE(img) = (xscale + yscale) / 2.0d0 + #IMG_ROT(img) = (xrot + yrot) / 2.0d0 + IMG_ROT(img) = xrot + + + # Now format a WCS text panel such as + # + # Projection: TAN System: Equatorial FK5 + # Ra/Dec axes: 1/2 Dimensions: 512 x 512 + # + # Center Pos: RA: 13:29:52.856 Dec: +47:11:40.39 + # Reference Pos: RA: 13:29:52.856 Dec: +47:11:40.39 + # Ref pixel coord: X: 250.256 Y: 266.309 + # Plate Scale: 0.765194 Rot Angle: 1.02939 + # Equinox: J2000.000 Epoch: J1987.25775240 + # MJD: 46890.39406 + + # Get some preliminary values. + if (idxstr (radecsys, Memc[radecstr], SZ_FNAME, EQTYPE_LIST) <= 0) + call strcpy ("FK5", Memc[radecstr], SZ_FNAME) + call strupr (Memc[radecstr]) + + if (idxstr (wtype, Memc[proj], SZ_FNAME, WTYPE_LIST) <= 0) + call strcpy ("logical", Memc[proj], SZ_FNAME) + call strupr (Memc[proj]) + + call fprintf (fd, "wcsinfo {\n") + + call fprintf (fd, + " Projection: %-6s\t System: %s %s\n") + call pargstr (Memc[proj]) + switch (ctype) { + case CTYPE_EQUATORIAL: + call pargstr ("Equatorial") + call pargstr (Memc[radecstr]) + case CTYPE_ECLIPTIC: + call pargstr ("Ecliptic") + call pargstr ("") + case CTYPE_GALACTIC: + call pargstr ("Galactic") + call pargstr ("") + case CTYPE_SUPERGALACTIC: + call pargstr ("SuperGalactic") + call pargstr ("") + default: + call pargstr ("Linear") + call pargstr ("") + } + + call fprintf (fd, " Ra/Dec axes: %d/%d") + call pargi (sk_stati (co, S_PLNGAX)) + call pargi (sk_stati (co, S_PLATAX)) + call fprintf (fd, " Dimensions: %d x %d\n\n") + call pargi (IM_LEN(im,1)) + call pargi (IM_LEN(im,2)) + + call fprintf (fd, + " Center Pos: %3s: %-12H %3s: %-12h\n") + if (ctype == CTYPE_EQUATORIAL) + call pargstr (" RA") + else + call pargstr ("Lon") + call pargd (cval1) + if (ctype == CTYPE_EQUATORIAL) + call pargstr ("Dec") + else + call pargstr ("Lat") + call pargd (cval2) + + call fprintf (fd, + " Reference Pos: %3s: %-12H %3s: %-12h\n") + if (ctype == CTYPE_EQUATORIAL) + call pargstr (" RA") + else + call pargstr ("Lon") + call pargd (crval1) + if (ctype == CTYPE_EQUATORIAL) + call pargstr ("Dec") + else + call pargstr ("Lat") + call pargd (crval2) + + call fprintf (fd, + " Reference Pixel: X: %-9.4f Y: %-9.4f\n") + call pargd (crpix1) + call pargd (crpix2) + + call fprintf (fd, + " Plate Scale: %-8f Rot Angle: %-8f\n") + call pargr (IMG_SCALE(img)) + call pargr (IMG_ROT(img)) + + call fprintf (fd, + " Equinox: %s%8f Epoch: %s%.6f\n") + switch (radecsys) { + case EQTYPE_FK5, EQTYPE_ICRS: + call pargstr ("J") ; call pargd (sk_statd(co,S_EQUINOX)) + call pargstr ("J") ; call pargd (sl_epj(sk_statd(co,S_EPOCH))) + default: + if (IMG_LINEAR(img) == YES) { + call pargstr (" ") ; call pargd (INDEFD) + call pargstr (" ") ; call pargd (INDEFD) + } else { + call pargstr ("B") + call pargd (sk_statd(co,S_EQUINOX)) + call pargstr ("B") + call pargd (sl_epb(sk_statd(co,S_EPOCH))) + } + } + + call fprintf (fd, " MJD: %.6f\n") + call pargd (sk_statd(co,S_EPOCH)) + + call fprintf (fd, "}\n \n \n") + + # Close the formatted string and send the message. + call close (fd) + call wcspix_message (Memc[buf]) + + call sfree (sp) +end + + +# IMG_SEND_PIXTAB -- Send a 'pixtab' message. Format of the message is +# +# pixtab { +# { {pix} {pix} ... } # pixel table values +# { {x1} {x2} ... } # column label values +# { {y1} {y2} ... } # row label values +# { } # pixtab statistics +# } +# + +procedure img_send_pixtab (pixtab, size, x1, x2, y1, y2) + +real pixtab[ARB] #i pixtab array +int size #i pixtab size +int x1, x2, y1, y2 #i raster boundaries + +pointer sp, buf, el +int i, j, npix +real pix, sum, sum2, mean, var, stdev, x, y + +define SZ_PIXTAB (6*SZ_LINE) + +begin + call smark (sp) + call salloc (buf, SZ_PIXTAB, TY_CHAR) + call salloc (el, SZ_FNAME, TY_CHAR) + + # Begin the pixtab message. + call strcpy ("pixtab {\n{\ntable {\n", Memc[buf], SZ_PIXTAB) + + # Format the pixels into a table for presentation. Do the y-flip + # here so the pixels are in order for the List widget in the GUI. + # Accumulate the pixel statistics so we don't have to do it in the + # GUI where it's slower. + + sum = 0.0 + sum2 = 0.0 + npix = size * size + + for (i=size - 1; i >= 0; i=i-1) { + for (j=1; j <= size; j=j+1) { + pix = pixtab[(i * size) + j] + sum = sum + pix + sum2 = sum2 + (pix * pix) + + call sprintf (Memc[el], SZ_FNAME, " {%10.1f}") + call pargr (pix) + + call strcat (Memc[el], Memc[buf], SZ_PIXTAB) + } + call strcat ("\n", Memc[buf], SZ_PIXTAB) + } + call strcat ("}\n}\n", Memc[buf], SZ_PIXTAB) + + + # Do the row and column label parts of the message. + call strcat ("{", Memc[buf], SZ_PIXTAB) + for (x = x1; x <= x2; x = x + 1.) { + call sprintf (Memc[el], SZ_FNAME, " {%10.1f}") + call pargr (x) + call strcat (Memc[el], Memc[buf], SZ_PIXTAB) + } + call strcat ("}\n", Memc[buf], SZ_PIXTAB) + + call strcat ("{", Memc[buf], SZ_PIXTAB) + for (y = y2; y >= y1; y = y - 1.) { + call sprintf (Memc[el], SZ_FNAME, " {%10.1f}") + call pargr (y) + call strcat (Memc[el], Memc[buf], SZ_PIXTAB) + } + call strcat ("}\n", Memc[buf], SZ_PIXTAB) + + + # Compute the statistics for the raster. + mean = sum / real(npix) + var = (sum2 - sum * mean) / real(npix - 1) + if (var <= 0) + stdev = 0.0 + else + stdev = sqrt (var) + + call sprintf (Memc[el], SZ_FNAME, " { %10.2f %10.4f }\n") + call pargr (mean) + call pargr (stdev) + call strcat (Memc[el], Memc[buf], SZ_PIXTAB) + + + # Close the message. + call strcat ("}", Memc[buf], SZ_PIXTAB) + + if (IMG_DEBUG) { + call eprintf ("pixtab: %s\n");call pargstr(Memc[buf]) + } + + # Send the formatted message. + call wcspix_message (Memc[buf]) + + call sfree (sp) +end + + +# IMG_AMP_WCS -- Create a WCS transformation for the amplifier coordinates. + +pointer procedure img_amp_wcs (im, mw) + +pointer im #i image pointer +pointer mw #i MWCS descriptor + +pointer ct +double r[IM_MAXDIM], w[IM_MAXDIM], cd[IM_MAXDIM,IM_MAXDIM] + +double imgetd() +pointer mw_sctran() + +begin + r[1] = 0.0d0 + r[2] = 0.0d0 + w[1] = imgetd (im, "ATV1") + w[2] = imgetd (im, "ATV2") + cd[1,1] = imgetd (im, "ATM1_1") + cd[1,2] = 0.0d0 + cd[2,1] = 0.0d0 + cd[2,2] = imgetd (im, "ATM2_2") + + # Create a new named system. + call mw_newsystem (mw, "amplifier", 2) + + # Set the new Wterm for the system. + call mw_swtermd (mw, r, w, cd, 2) + + # Set up the transform. + ct = mw_sctran (mw, "logical", "amplifier", 03B) + + # Reset the default world system. + call mw_sdefwcs (mw) + + return (ct) +end + + +# IMG_DET_WCS -- Create a WCS transformation for the detector coordinates. + +pointer procedure img_det_wcs (im, mw) + +pointer im #i image pointer +pointer mw #i MWCS descriptor + +pointer ct +double r[IM_MAXDIM], w[IM_MAXDIM], cd[IM_MAXDIM,IM_MAXDIM] + +double imgetd() +pointer mw_sctran() + +begin + r[1] = 0.0d0 + r[2] = 0.0d0 + w[1] = imgetd (im, "DTV1") + w[2] = imgetd (im, "DTV2") + cd[1,1] = imgetd (im, "DTM1_1") + cd[1,2] = 0.0d0 + cd[2,1] = 0.0d0 + cd[2,2] = imgetd (im, "DTM2_2") + + # Create a new named system. + call mw_newsystem (mw, "detector", 2) + + # Set the new Wterm for the system. + call mw_swtermd (mw, r, w, cd, 2) + + # Set up the transform. + ct = mw_sctran (mw, "logical", "detector", 03B) + + # Reset the default world system. + call mw_sdefwcs (mw) + + return (ct) +end + + +# IMG_COORD_LABELS -- Get the WCS name, coord labels and format strings for +# the specified object. + +procedure img_coord_labels (cp, line, wcsname, xunits, yunits) + +pointer cp #i cache pointer +pointer line #i WCS output line +char wcsname[ARB] #o WCS name string +char xunits[ARB], yunits[ARB] #o WCS coord labels + +pointer img, co, wp +pointer sp, proj, radecstr + +int strcmp(), sk_stati(), idxstr() + +begin + img = C_DATA(cp) # initialize ptrs + co = IMG_CO(img) + wp = IMG_WP(img) + + if (SYSTEMS(wp,line) == SYS_WORLD) { + switch (sk_stati(co,S_CTYPE)) { + case CTYPE_EQUATORIAL: + call strcpy (" RA", xunits, LEN_WCSNAME) + call strcpy (" Dec", yunits, LEN_WCSNAME) + case CTYPE_ECLIPTIC: + call strcpy ("ELon", xunits, LEN_WCSNAME) + call strcpy ("ELat", yunits, LEN_WCSNAME) + case CTYPE_GALACTIC: + call strcpy ("GLon", xunits, LEN_WCSNAME) + call strcpy ("GLat", yunits, LEN_WCSNAME) + case CTYPE_SUPERGALACTIC: + call strcpy ("SLon", xunits, LEN_WCSNAME) + call strcpy ("SLat", yunits, LEN_WCSNAME) + } + } else if (SYSTEMS(wp,line) == SYS_SKY) { + call strcpy (WCSNAME(wp,line), wcsname, LEN_WCSNAME) + call strlwr (wcsname) + if (strcmp (wcsname,"ecliptic") == 0) { + call strcpy ("ELon", xunits, LEN_WCSNAME) + call strcpy ("ELat", yunits, LEN_WCSNAME) + } else if (strcmp (wcsname,"galactic") == 0) { + call strcpy ("GLon", xunits, LEN_WCSNAME) + call strcpy ("GLat", yunits, LEN_WCSNAME) + } else if (strcmp (wcsname,"supergalactic") == 0) { + call strcpy ("SLon", xunits, LEN_WCSNAME) + call strcpy ("SLat", yunits, LEN_WCSNAME) + } else { + call strcpy (" RA", xunits, LEN_WCSNAME) + call strcpy (" Dec", yunits, LEN_WCSNAME) + } + } else { + call strcpy ("X", xunits, LEN_WCSNAME) + call strcpy ("Y", yunits, LEN_WCSNAME) + } + + + # Now get the format strings. For systems other than the image + # default just use the WCS string as the name, otherwise format a + # string giving more information about the system. + if (SYSTEMS(wp,line) != SYS_WORLD) + call strcpy (WCSNAME(wp,line), wcsname, LEN_WCSNAME) + + else { + call smark (sp) + call salloc (radecstr, SZ_FNAME, TY_CHAR) + call salloc (proj, SZ_FNAME, TY_CHAR) + + call sprintf (wcsname, LEN_WCSNAME, "%s-%s-%s") + + switch (sk_stati(co,S_CTYPE)) { + case CTYPE_EQUATORIAL: call pargstr ("EQ") + case CTYPE_ECLIPTIC: call pargstr ("ECL") + case CTYPE_GALACTIC: call pargstr ("GAL") + case CTYPE_SUPERGALACTIC: call pargstr ("SGAL") + default: call pargstr ("UNKN") + } + + if (sk_stati(co,S_CTYPE) == CTYPE_EQUATORIAL) { + if (idxstr(sk_stati(co,S_RADECSYS), Memc[radecstr], + SZ_FNAME, EQTYPE_LIST) <= 0) + call strcpy ("FK5", Memc[radecstr], SZ_FNAME) + call strupr (Memc[radecstr]) + call pargstr (Memc[radecstr]) + } else { + if (sk_stati(co,S_CTYPE) == CTYPE_SUPERGALACTIC) + call pargstr ("-") + else + call pargstr ("--") + } + + if (idxstr(sk_stati(co,S_WTYPE), Memc[proj], SZ_FNAME, + WTYPE_LIST) <= 0) + call strcpy ("linear", Memc[proj], SZ_FNAME) + call strupr (Memc[proj]) + call pargstr (Memc[proj]) + + call sfree (sp) + } + + # Now fix up the WCS system name. + if (strcmp (wcsname, "fk4") == 0 || + strcmp (wcsname, "fk5") == 0 || + strcmp (wcsname, "icrs") == 0 || + strcmp (wcsname, "gappt") == 0 || + strcmp (wcsname, "fk4-no-e") == 0) { + call strupr (wcsname) + + } else if (IS_LOWER(wcsname[1])) + wcsname[1] = TO_UPPER(wcsname[1]) +end + + +# IMG_COORD_FMT -- Format the coordinate strings. + +procedure img_coord_fmt (cp, line, xval, yval, xc, yc) + +pointer cp #i object cache pointer +int line #i output line number +double xval, yval #i input coords +char xc[ARB], yc[ARB] #o formatted coord strings + +pointer img, co, wp +char xfmt[LEN_WCSNAME], yfmt[LEN_WCSNAME] + +int sk_stati() +bool streq() + +begin + img = C_DATA(cp) # initialize ptrs + co = IMG_CO(img) + wp = IMG_WP(img) + + # Convert coords to the requested format. + if (FORMATS(wp,line) == FMT_DEFAULT) { + if (IMG_MW(img) == NULL) { + call strcpy ("%10.2f", xfmt, LEN_WCSNAME) + call strcpy ("%10.2f", yfmt, LEN_WCSNAME) + } else { + if (SYSTEMS(wp,line) == SYS_WORLD || + SYSTEMS(wp,line) == SYS_SKY) { + + if (streq(WCSNAME(wp,line),"ecliptic") || + streq(WCSNAME(wp,line),"galactic") || + streq(WCSNAME(wp,line),"supergalactic")) + call strcpy ("%h", xfmt, LEN_WCSNAME) + else + call strcpy ("%.2H", xfmt, LEN_WCSNAME) + call strcpy ("%.1h", yfmt, LEN_WCSNAME) + } else { + call strcpy ("%10.2f", xfmt, LEN_WCSNAME) + call strcpy ("%10.2f", yfmt, LEN_WCSNAME) + } + } + + } else if (FORMATS(wp,line) == FMT_HMS) { + if (sk_stati(co, S_CTYPE) == CTYPE_EQUATORIAL) + call strcpy ("%.2H", xfmt, LEN_WCSNAME) + else + call strcpy ("%.1h", xfmt, LEN_WCSNAME) + call strcpy ("%h", yfmt, LEN_WCSNAME) + } else { + call strcpy ("%10.2f", xfmt, LEN_WCSNAME) + call strcpy ("%10.2f", yfmt, LEN_WCSNAME) + } + + # Convert the value to the requested format + call sprintf (xc, LEN_WCSNAME, xfmt) + if (FORMATS(wp,line) != FMT_RAD) + call pargd (xval) + else + call pargd (DEGTORAD(xval)) + + call sprintf (yc, LEN_WCSNAME, yfmt) + if (FORMATS(wp,line) != FMT_RAD) + call pargd (yval) + else + call pargd (DEGTORAD(yval)) +end + + +# IMG_GET_COORD -- Given an x,y position in the image return the coordinate in +# the given system. + +procedure img_get_coord (img, x, y, system, wcsname, wx, wy) + +pointer img #i IMG struct pointer +double x, y #i input image position +int system #i coordinate system requested +char wcsname[ARB] #i desired WCS name +double wx, wy #o output coordinates + +double ox, oy, tmp +real epoch +pointer im, co, nco +char buf[SZ_LINE] +int stat + +real imgetr() +int imaccf(), sk_stati(), sk_decwstr() +bool streq() + +errchk imgetr + +begin + im = IMG_IM(img) + co = IMG_CO(img) + + wx = x # fallback values + wy = y + + switch (system) { + case SYS_NONE: + wx = x + wy = y + case SYS_DISPLAY: + call img_ltov (im, x, y, wx, wy) + #wx = x + #wy = y + case SYS_PHYSICAL: + if (IMG_CTP(img) != NULL) + call mw_c2trand (IMG_CTP(img), x, y, wx, wy) + case SYS_WORLD: + if (IMG_CTW(img) != NULL) { + call mw_c2trand (IMG_CTW(img), x, y, wx, wy) + + # Check for transposed image. + if (sk_stati(co,S_PLATAX) < sk_stati(co,S_PLNGAX)) { + tmp = wx + wx = wy + wy = tmp + } + } + case SYS_AMP: + if (IMG_CTA(img) != NULL) + call mw_c2trand (IMG_CTA(img), x, y, wx, wy) + case SYS_CCD: + if (IMG_CTD(img) != NULL) + call mw_c2trand (IMG_CTD(img), x, y, wx, wy) + case SYS_DETECTOR: + if (IMG_CTD(img) != NULL) + call mw_c2trand (IMG_CTD(img), x, y, wx, wy) + case SYS_SKY: + # Note Ecliptic/GAPPT coords need an epoch value. + if (imaccf (im, "EPOCH") == YES) { + epoch = imgetr (im, "EPOCH") + if (epoch == 0.0 || IS_INDEFR(epoch)) + epoch = 1950.0 + } else + epoch = 1950.0 + + if (streq (wcsname, "ecliptic") || streq (wcsname, "gappt")) { + call sprintf (buf, SZ_LINE, "%s %.1f") + if (streq (wcsname, "gappt")) + call pargstr ("apparent") + else + call pargstr (wcsname) + call pargr (epoch) + } else { + call sprintf (buf, SZ_LINE, "%s") + if (streq(wcsname,"gappt")) + call pargstr ("apparent") + else if (streq(wcsname,"fk4-no-e")) + call pargstr ("noefk4") + else + call pargstr (wcsname) + } + + stat = sk_decwstr (buf, nco, co) + if (stat != ERR) { + if (IMG_CTW(img) != NULL) + call mw_c2trand (IMG_CTW(img), x, y, ox, oy) + call sk_lltran (co, nco, DEGTORAD(ox), DEGTORAD(oy), + INDEFD, INDEFD, 0.0d0, 0.0d0, wx, wy) + if (sk_stati(co,S_PLATAX) < sk_stati(co,S_PLNGAX)) { + wx = RADTODEG(wy) # transposed image + wy = RADTODEG(wx) + } else { + wx = RADTODEG(wx) # regular image + wy = RADTODEG(wy) + } + } else { + wx = x + wy = y + } + case SYS_OTHER: + ; # TBD + + default: # default coords + wx = x + wy = y + } +end + + +# IMG_LTOV -- Convert coordinate from the logical coordinate system to the +# output coordinate system. + +procedure img_ltov (im, xin, yin, xout, yout) + +pointer im # the input image descriptor +double xin # the input x coordinate +double yin # the input y coordinate +double xout # the output x coordinate +double yout # the output y coordinate + +int index1, index2 + +begin + index1 = IM_VMAP(im,1) + index2 = IM_VMAP(im,2) + + xout = xin * IM_VSTEP(im,index1) + IM_VOFF(im,index1) + yout = yin * IM_VSTEP(im,index2) + IM_VOFF(im,index2) +end + + +# IMG_VTOL -- Convert coordinate from the tv coordinate system to the +# logical coordinate system. + +procedure img_vtol (im, xin, yin, xout, yout) + +pointer im # the input image descriptor +double xin # the input x coordinate +double yin # the input y coordinate +double xout # the output x coordinate +double yout # the output y coordinate + +int index1, index2 + +begin + index1 = IM_VMAP(im,1) + index2 = IM_VMAP(im,2) + + xout = (xin - IM_VOFF(im,index1)) / IM_VSTEP(im,index1) + yout = (yin - IM_VOFF(im,index2)) / IM_VSTEP(im,index2) +end diff --git a/vendor/x11iraf/ximtool/clients/wcspix/wcmef.x b/vendor/x11iraf/ximtool/clients/wcspix/wcmef.x new file mode 100644 index 00000000..050e5596 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients/wcspix/wcmef.x @@ -0,0 +1,50 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "wcspix.h" + + +# MEF Image class data. + + +# MEF_INIT -- Initialize the MEF Class module. + +procedure mef_init () +begin +end + + +# MEF_CACHE -- Cache an image in the object cache. + +procedure mef_cache () +begin +end + + +# MEF_UNCACHE -- Uncache an image in the object cache. + +procedure mef_uncache () +begin +end + + +# MEF_WCSTRAN -- Translate object source (x,y) coordinates to the +# desired output WCSs. + +procedure mef_wcstran () +begin +end + + +# MEF_WCSLIST -- List the WCSs available for the given image. + +procedure mef_wcslist () +begin +end + + +# MEF_OBJINFO -- Get header information from the image. + +procedure mef_objinfo () +begin +end + diff --git a/vendor/x11iraf/ximtool/clients/wcspix/wcmspec.x b/vendor/x11iraf/ximtool/clients/wcspix/wcmspec.x new file mode 100644 index 00000000..64198d69 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients/wcspix/wcmspec.x @@ -0,0 +1,50 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "wcspix.h" + + +# Multispec image class data. + + +# MSP_INIT -- Initialize the Image Class module. + +procedure msp_init () +begin +end + + +# MSP_CACHE -- Cache an image in the object cache. + +procedure msp_cache () +begin +end + + +# MSP_UNCACHE -- Uncache an image in the object cache. + +procedure msp_uncache () +begin +end + + +# MSP_WCSTRAN -- Translate object source (x,y) coordinates to the +# desired output WCSs. + +procedure msp_wcstran () +begin +end + + +# MSP_WCSLIST -- List the WCSs available for the given image. + +procedure msp_wcslist () +begin +end + + +# MSP_OBJINFO -- Get header information from the image. + +procedure msp_objinfo () +begin +end + diff --git a/vendor/x11iraf/ximtool/clients/wcspix/wcspix.h b/vendor/x11iraf/ximtool/clients/wcspix/wcspix.h new file mode 100644 index 00000000..0233ff21 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients/wcspix/wcspix.h @@ -0,0 +1,112 @@ +# WCSPIX.H -- Include file for the WCS/Pixel value ISM task + +define WCSPIX_NAME "wcspix" +define WCSPIX_MODE "text" +define WCSPIX_CONNECT "unix:/tmp/.ISM%d" + +define WCSPIX_DBG FALSE + +# Main task data structures. +define MAX_WCSLINES 4 # max WCS output lines +define LEN_PIXTAB 81 # size of pixel table +define LEN_WCSNAME 32 # size of a WCS name + +define SZ_WCSPIX 7 +define WP_CPTR Memi[$1 ] # object cache pointer +define WP_PTABSZ Memi[$1+1] # pixel table size +define WP_BPM Memi[$1+2] # get BPM data +define WP_SYSTEMS Memi[$1+3] # WCS readout systems +define WP_WCS Memi[$1+4] # WCS system string +define WP_FORMATS Memi[$1+5] # WCS readout formats +define WP_DBGLEVEL Memi[$1+6] # debug level + +define OBJCACHE Memi[WP_CPTR($1)+$2] # object cache +define SYSTEMS Memi[WP_SYSTEMS($1)+$2-1] +define FORMATS Memi[WP_FORMATS($1)+$2-1] +define WCSNAME Memc[WP_WCS($1)+(LEN_WCSNAME*($2-1))] + + +# Element of an object cache. +define SZ_CACHE 256 # size of object cache +define SZ_CNODE 135 # size of a cache node +define SZ_OBJREF 128 # size of a object reference + +define C_OBJID Memi[$1] # object id +define C_REGID Memi[$1+1] # region id +define C_CLASS Memi[$1+2] # object class +define C_DATA Memi[$1+3] # object data ptr +define C_NREF Memi[$1+4] # no. times object referenced +define C_REF Memc[P2C($1+6)] # object reference file + + +# WCSPIX ISM task methods. +define WCSPIX_CMDS "|set|get|quit|initialize|cache|uncache\ + |wcstran|wcslist|objinfo|debug" + +define SET 1 +define GET 2 +define QUIT 3 +define INITIALIZE 4 +define CACHE 5 +define UNCACHE 6 +define WCSTRAN 7 +define WCSLIST 8 +define OBJINFO 9 +define DEBUG 10 + +# Parameters definable from the GUI +define SZ_PARAM 32 # size of a parameter string + +define WCSPIX_SYSTEMS "|none|display|logical|physical|world|sky\ + |amplifier|ccd|detector|other|" +define SYS_NONE 1 # no coords requested +define SYS_DISPLAY 2 # image display coords +define SYS_LOGICAL 3 # logical coords +define SYS_PHYSICAL 4 # physical coords +define SYS_WORLD 5 # world coords +define SYS_SKY 6 # sky coords +define SYS_AMP 7 # amplifier coords +define SYS_CCD 8 # CCD coords +define SYS_DETECTOR 9 # detector coords +define SYS_OTHER 10 # ??? coords + +define SKYPROJ "FK5 FK4 ICRS GAPPT FK4-NO-E Ecliptic Galactic Supergalactic" + + +define WCSPIX_PARAMS "|psize|bpm|wcs|format|" +define PAR_PSIZE 1 # pixel table size +define PAR_BPM 2 # get BPM data +define PAR_WCS 3 # WCS system +define PAR_FMT 4 # WCS format + +define WCSPIX_FMT "|default|hms|degrees|radians|" +define FMT_DEFAULT 1 # no formatting +define FMT_HMS 2 # covert to sexigesimal +define FMT_DEG 3 # output degrees +define FMT_RAD 4 # output radians + +define DEF_PTABSZ 0 # default pixtable size +define DEF_FMT FMT_DEFAULT # default output format +define DEF_SYSTEM SYS_LOGICAL # default coord system +define DEF_BPM_FLAG NO # default get-BPM-data flag + + +# Object class definitions. +define UNKNOWN_CLASS 1 # unknown class +define IMAGE_CLASS 2 # generic image class +define MEF_CLASS 3 # Mosaic MEF image class +define MULTISPEC_CLASS 4 # multispec data class + +# Class methods. +define LEN_CLASS 6 # length of class table +define MAX_CLASSES 16 # max supported classes +define SZ_CLNAME 32 # size of a class name + +define CL_INIT cl_table[1,$1] # class initializer +define CL_CACHE cl_table[2,$1] # cache the object +define CL_UNCACHE cl_table[3,$1] # uncache the object +define CL_WCSTRAN cl_table[4,$1] # WCS tranformations +define CL_WCSLIST cl_table[5,$1] # list available WCS +define CL_OBJINFO cl_table[6,$1] # get object header +define CL_NAME cl_names[1,$1] # class name + diff --git a/vendor/x11iraf/ximtool/clients/wcspix/wcunknown.x b/vendor/x11iraf/ximtool/clients/wcspix/wcunknown.x new file mode 100644 index 00000000..86e5e6d8 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients/wcspix/wcunknown.x @@ -0,0 +1,185 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include +include "wcspix.h" + + +# Unknown class data. +define LEN_UNKDATA 1 +define UNK_WP Memi[$1 ] # wcspix back-pointer + + +# UNK_INIT -- Initialize the object structure. + +procedure unk_init (cp, wp) + +pointer cp #i cache pointer +pointer wp #i WCSPIX structure + +begin + # Allocate the image data structure if not previously allocated. + if (C_DATA(cp) == NULL) { + iferr (call calloc (C_DATA(cp), LEN_UNKDATA, TY_STRUCT)) + return + } + + UNK_WP(C_DATA(cp)) = wp +end + + +# UNK_CACHE -- Cache an image in the object cache. Since we don't know +# what this is we simply setup so that a query to the object id will still +# return a result of some kind rather than ignore it. In most cases this +# just means the input arguments are echoed back (e.g. coords), or default +# values such as a rotation value can be retrieved. + +procedure unk_cache (cp, objid, regid, ref) + +pointer cp #i cache pointer +int objid #i object id +int regid #i region id +char ref[ARB] #i object reference + +begin + C_OBJID(cp) = objid + C_REGID(cp) = regid + C_NREF(cp) = C_NREF(cp) + 1 + call strcpy (ref, C_REF(cp), 128) +end + + +# UNK_UNCACHE -- Uncache an unknown image in the object cache. + +procedure unk_uncache (cp, id) + +pointer cp #i cache pointer +int id #i image id + +begin + C_OBJID(cp) = NULL + C_NREF(cp) = 0 + call strcpy ("", C_REF(cp), SZ_FNAME) + + call mfree (C_DATA(cp), TY_STRUCT) + C_DATA(cp) = NULL +end + + +# UNK_WCSTRAN -- Translate object source (x,y) coordinates to the +# desired output WCSs. Message is returned as something like: +# +# set value { +# { object } { region } +# { pixval [] } +# { coord [ ] } +# { coord [ ] } +# } + + +procedure unk_wcstran (cp, id, x, y) + +pointer cp #i cache pointer +int id #i image id +real x, y #i source coords + +pointer wp +int i + +# Use static storage to avoid allocation overhead. +char buf[SZ_LINE], msg[SZ_LINE] + +begin + wp = UNK_WP(C_DATA(cp)) + + # Begin formatting the message. + call aclrc (msg, SZ_LINE) + call sprintf (msg, SZ_LINE, "wcstran { object %d } { region %d } ") + call pargi (C_OBJID(cp)) + call pargi (C_REGID(cp)) + call strcat ("{ pixval 0.0 } { bpm 0 } \n", msg, SZ_LINE) + + + # Now loop over the requested systems and generate a coordinate + # for each. + for (i=1; i <= MAX_WCSLINES; i=i+1) { + + # Format the coord buffer and append it to the message. + call sprintf (buf, SZ_LINE, "{coord {%9s} {%12g} {%12g} {X} {Y}}\n") + call pargstr ("UNKN") + call pargr (x) + call pargr (y) + call strcat (buf, msg, SZ_LINE) + } + + # Now send the completed message. + call wcspix_message (msg) +end + + +# UNK_WCSLIST -- List the WCSs available for the given image. + +procedure unk_wcslist (cp, id) + +pointer cp #i cache pointer +int id #i image id + +begin + #call wcspix_message ("wcslist {None Logical}") +end + + +# UNK_GETDATA -- Get data from the image. + +procedure unk_getdata (cp, id, x, y, pixval) + +pointer cp #i cache pointer +int id #i image id +real x, y #i source coords +real pixval #o central pixel value + +pointer wp, pix +int size, x1, x2, y1, y2 + +begin + wp = UNK_WP(C_DATA(cp)) + size = WP_PTABSZ(wp) + + # Compute the box offset given the center and size. + x1 = x - size / 2 + 0.5 + x2 = x + size / 2 + 0.5 + y1 = y - size / 2 + 0.5 + y2 = y + size / 2 + 0.5 + + pixval = 0.0 + + # Send the pixel table. + if (size > 1) { + call calloc (pix, size * size, TY_REAL) + call img_send_pixtab (Memr[pix], size, x1, x2, y1, y2) + call mfree (pix, TY_REAL) + } +end + + +# UNK_OBJINFO -- Get header information from the image. + +procedure unk_objinfo (cp, id, template) + +pointer cp #i cache pointer +int id #i image id +char template[ARB] #i keyword template + +pointer sp, buf + +begin + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + + # Send a default (X,Y) compass indicator. + call aclrc (Memc[buf], SZ_LINE) + call sprintf (Memc[buf], SZ_LINE, "compass %d 0.0 -1 1 0 X Y\0") + call pargi (C_OBJID(cp)) + call wcspix_message (Memc[buf]) + + call sfree (sp) +end -- cgit