diff options
Diffstat (limited to 'vendor/x11iraf/ximtool/clients.old')
77 files changed, 17685 insertions, 0 deletions
diff --git a/vendor/x11iraf/ximtool/clients.old/.DONE b/vendor/x11iraf/ximtool/clients.old/.DONE new file mode 100644 index 00000000..e69de29b --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/.DONE diff --git a/vendor/x11iraf/ximtool/clients.old/DONE b/vendor/x11iraf/ximtool/clients.old/DONE new file mode 100644 index 00000000..e69de29b --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/DONE diff --git a/vendor/x11iraf/ximtool/clients.old/Imakefile b/vendor/x11iraf/ximtool/clients.old/Imakefile new file mode 100644 index 00000000..3ab5b034 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/Imakefile @@ -0,0 +1,32 @@ +XCOMM Imakefile for the Image Support Module components. + +X11IRAFDIR = ../../ +#include <../../X11IRAF.tmpl> + + WC_SRCS = wcspix/t_wcspix.x wcspix/wcimage.x wcspix/wcmef.x \ + wcspix/wcmspec.x wcspix/wcspix.h + LIB_SRCS = lib/dspmmap.x lib/reopen.x lib/ximtool.x + + +all:: ism_wcspix.e + +ism_wcspix.e: $(WC_SRCS) $(LIB_SRCS) + mkpkg relink + touch DONE + +SubdirLibraryRule($(WC_SRCS) $(LIB_SRCS)) + +clean:: + $(RM) *.[aeo] + touch DONE + +includes:: + +#if InstallBinaries +install:: ism_wcspix.e + -@if [ -d X11irafBinDir ]; then set +x; \ + else (set -x; $(MKDIRHIER) X11irafBinDir); fi + mv ism_wcspix.e X11irafBinDir +#endif + +DependTarget() diff --git a/vendor/x11iraf/ximtool/clients.old/README b/vendor/x11iraf/ximtool/clients.old/README new file mode 100644 index 00000000..e69de29b --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/README diff --git a/vendor/x11iraf/ximtool/clients.old/_spplint b/vendor/x11iraf/ximtool/clients.old/_spplint new file mode 100644 index 00000000..28486ee8 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/_spplint @@ -0,0 +1,489 @@ +/u2/fitz/iraf/ximtool/clients/x_ism.x + sys_runtask: +/u2/fitz/iraf/ximtool/clients/wcspix/t_wcspix.x + t_wcspix: + wp_initialize: + wp_cache: + wp_uncache: + wp_wcstran: + wp_wcslist: + wp_objinfo: + wp_setpar: + wp_getpar: + wp_init: + wp_shutdown: + wp_class: + wp_id2obj: + wp_class_init: + wp_load_class: + wcspix_message: + wp_cnvdate: + dbg_printcache: +/u2/fitz/iraf/ximtool/clients/wcspix/wcimage.x + img_init: + img_cache: + img_uncache: + img_wcstran: + img_wcslist: + img_get_data: + img_objinfo: + img_send_header: + img_send_compass: + img_send_wcsinfo: + img_send_pixtab: + img_amp_wcs: + img_det_wcs: + img_coord_labels: + img_coord_fmt: + img_get_coord: +/u2/fitz/iraf/ximtool/clients/wcspix/wcmef.x + mef_init: + mef_cache: + mef_uncache: + mef_wcstran: + mef_wcslist: + mef_objinfo: +/u2/fitz/iraf/ximtool/clients/wcspix/wcmspec.x + msp_init: + msp_cache: + msp_uncache: + msp_wcstran: + msp_wcslist: + msp_objinfo: +/u2/fitz/iraf/ximtool/clients/wcspix/wcunknown.x + unk_init: + unk_cache: + unk_uncache: + unk_wcstran: + unk_wcslist: + unk_getdata: + unk_objinfo: +/u2/fitz/iraf/ximtool/clients/lib/dspmmap.x + ds_pmmap: + ds_pmimmap: + ds_match: +/u2/fitz/iraf/ximtool/clients/lib/reopen.x + reopen: +/u2/fitz/iraf/ximtool/clients/lib/skywcs/skdecode.x + sk_decwcs: + sk_decwstr: + sk_decim: + sk_strwcs: + sk_imwcs: + sk_enwcs: + sk_copy: + sk_close: +/u2/fitz/iraf/ximtool/clients/lib/skywcs/sksaveim.x + sk_saveim: + sk_ctypeim: +/u2/fitz/iraf/ximtool/clients/lib/skywcs/skset.x + sk_setd: + sk_seti: + sk_sets: +/u2/fitz/iraf/ximtool/clients/lib/skywcs/skstat.x + sk_statd: + sk_stati: + sk_stats: +/u2/fitz/iraf/ximtool/clients/lib/skywcs/sktransform.x + sk_ultran: + sk_lltran: + sk_equatorial: +/u2/fitz/iraf/ximtool/clients/lib/skywcs/skwrdstr.x + sk_wrdstr: +/u2/fitz/iraf/ximtool/clients/lib/skywcs/skwrite.x + sk_iiprint: + sk_iiwrite: + sk_inprint: + sk_inwrite: + sk_imprint: + sk_imwrite: +/u2/fitz/iraf/ximtool/clients/lib/ximtool.x + xim_connect: + xim_disconnect: + xim_message: + xim_alert: + xim_write: + xim_read: + xim_intrhandler: + xim_zxwhen: + xim_onerror: +/u2/fitz/iraf/ximtool/clients/lib/idxstr.x + idxstr: +/u2/fitz/iraf/ximtool/clients/lib/wcsgfterm.x + wcs_gfterm: +Making function prototype file..... +FTN.f: + dspmmp: + dspmip: + dsmath: +Warning on line 279 of FTN.f: inconsistent calling sequences for mwctrd: + here 4, previously 3 args and string lengths. + idxstr: + reopen: + skdecs: + skdecr: + skdecm: + skstrs: + skimws: + skenws: + skcopy: + skcloe: + sksavm: + skctym: + sksetd: + skseti: + sksets: + skstad: + skstai: + skstas: + skultn: + sklltn: + skequl: + skwrdr: + skiipt: + skiiwe: + skinpt: + skinwe: + skimpt: + skimwe: + twcspx: + wpinie: + wpcace: + wpunce: + wpwcsn: +Warning on line 4823 of FTN.f: inconsistent calling sequences for zcall4, + arg 4: here real variable, previously integer variable. + wpwcst: + wpobjo: + wpsetr: + wpgetr: + wpinit: + wpshun: + wpclas: + wpid2j: + wpclat: + wploas: + wcspie: + wpcnve: + dbgpre: + imgint: + imgcae: + imgune: + imgwcn: + imgwct: + imggea: + imgobo: + imgser: + imgses: + imgseo: + imgseb: + imgams: + imgdes: + imgcos: + imgcot: + imgged: + mefint: + mefcae: + mefune: + mefwcn: + mefwct: + mefobo: + mspint: + mspcae: + mspune: + mspwcn: + mspwct: + mspobo: + wcsgfm: + unkint: + unkcae: + unkune: + unkwcn: + unkwct: + unkgea: + unkobo: + sysruk: + ximcot: + ximdit: + ximmee: + ximalt: + ximwre: + ximred: + ximinr: + ximzxn: + ximonr: +Warning on line 8474 of FTN.f: inconsistent calling sequences for ximalt, + arg 2: here integer variable, previously integer*2 variable. +Rerunning "f2c -P ... FTN.f FTN.P" may change prototypes or declarations. +Converting fortran source file..... +First pass.... +FTN.f: + dspmmp: + dspmip: + dsmath: +Warning on line 264 of FTN.f: inconsistent calling sequences for mwctrd: + here 3, previously 4 args and string lengths. + idxstr: + reopen: + skdecs: + skdecr: + skdecm: + skstrs: + skimws: + skenws: + skcopy: + skcloe: + sksavm: + skctym: + sksetd: + skseti: + sksets: + skstad: + skstai: + skstas: + skultn: + sklltn: + skequl: + skwrdr: + skiipt: + skiiwe: + skinpt: + skinwe: + skimpt: + skimwe: + twcspx: + wpinie: + wpcace: + wpunce: + wpwcsn: +Warning on line 4823 of FTN.f: inconsistent calling sequences for zcall4, + arg 4: here real variable, previously integer variable. + wpwcst: + wpobjo: + wpsetr: + wpgetr: + wpinit: + wpshun: + wpclas: + wpid2j: + wpclat: + wploas: + wcspie: + wpcnve: + dbgpre: + imgint: + imgcae: + imgune: + imgwcn: + imgwct: + imggea: + imgobo: + imgser: + imgses: + imgseo: + imgseb: + imgams: + imgdes: + imgcos: + imgcot: + imgged: + mefint: + mefcae: + mefune: + mefwcn: + mefwct: + mefobo: + mspint: + mspcae: + mspune: + mspwcn: + mspwct: + mspobo: + wcsgfm: + unkint: + unkcae: + unkune: + unkwcn: + unkwct: + unkgea: + unkobo: + sysruk: + ximcot: + ximdit: + ximmee: + ximalt: + ximwre: + ximred: + ximinr: + ximzxn: + ximonr: +Warning on line 8474 of FTN.f: inconsistent calling sequences for ximalt, + arg 2: here integer variable, previously integer*2 variable. +Second pass.... +dspmmap.f: + dspmmp: + dspmip: + dsmath: +Warning on line 264 of dspmmap.f: inconsistent calling sequences for mwctrd: + here 3, previously 4 args and string lengths. +idxstr.f: + idxstr: +reopen.f: + reopen: +skdecode.f: + skdecs: + skdecr: + skdecm: + skstrs: + skimws: + skenws: + skcopy: + skcloe: +sksaveim.f: + sksavm: + skctym: +skset.f: + sksetd: + skseti: + sksets: +skstat.f: + skstad: + skstai: + skstas: +sktransform.f: + skultn: + sklltn: + skequl: +skwrdstr.f: + skwrdr: +skwrite.f: + skiipt: + skiiwe: + skinpt: + skinwe: + skimpt: + skimwe: +t_wcspix.f: + twcspx: + wpinie: + wpcace: + wpunce: + wpwcsn: +Warning on line 414 of t_wcspix.f: inconsistent calling sequences for zcall4, + arg 4: here real variable, previously integer variable. + wpwcst: + wpobjo: + wpsetr: + wpgetr: + wpinit: + wpshun: + wpclas: + wpid2j: + wpclat: + wploas: + wcspie: + wpcnve: + dbgpre: +wcimage.f: + imgint: + imgcae: + imgune: + imgwcn: + imgwct: + imggea: + imgobo: + imgser: + imgses: + imgseo: + imgseb: + imgams: + imgdes: + imgcos: + imgcot: + imgged: +wcmef.f: + mefint: + mefcae: + mefune: + mefwcn: + mefwct: + mefobo: +wcmspec.f: + mspint: + mspcae: + mspune: + mspwcn: + mspwct: + mspobo: +wcsgfterm.f: + wcsgfm: +wcunknown.f: + unkint: + unkcae: + unkune: + unkwcn: + unkwct: + unkgea: + unkobo: +x_ism.f: + sysruk: +ximtool.f: + ximcot: + ximdit: + ximmee: + ximalt: + ximwre: + ximred: + ximinr: + ximzxn: + ximonr: +Warning on line 482 of ximtool.f: inconsistent calling sequences for ximalt, + arg 2: here integer variable, previously integer*2 variable. +Running LINT on converted C source.... +dspmmap.c: +dspmmap.c(152): warning: argument refim unused in function dspmip_ +idxstr.c: +reopen.c: +skdecode.c: +sksaveim.c: +skset.c: +skstat.c: +sktransform.c: +skwrdstr.c: +skwrite.c: +t_wcspix.c: +t_wcspix.c(830): warning: argument wp unused in function wpgetr_ +wcimage.c: +wcimage.c(257): warning: argument id unused in function imgune_ +wcimage.c(380): warning: im set but not used in function imgwcn_ +wcimage.c(430): warning: argument id unused in function imgwct_ +wcimage.c(470): warning: im set but not used in function imgwct_ +wcimage.c(510): warning: argument id unused in function imggea_ +wcimage.c(609): warning: argument id unused in function imgobo_ +wcimage.c(899): warning: co set but not used in function imgses_ +wcmef.c: +wcmspec.c: +wcsgfterm.c: +wcsgfterm.c(122): warning: errcoe set but not used in function wcsgfm_ +wcunknown.c: +wcunknown.c(108): warning: argument id unused in function unkune_ +wcunknown.c(173): warning: wp set but not used in function unkwcn_ +wcunknown.c(144): warning: argument id unused in function unkwcn_ +wcunknown.c(208): warning: argument cp unused in function unkwct_ +wcunknown.c(208): warning: argument id unused in function unkwct_ +wcunknown.c(234): warning: argument id unused in function unkgea_ +wcunknown.c(284): warning: argument id unused in function unkobo_ +x_ism.c: +ximtool.c: +ximtool.c(573): warning: argument nexthr unused in function ximzxn_ +ximtool.c(603): warning: code set but not used in function ximonr_ +Lint pass2: +mwctrd_: variable # of args. dspmmap.c(362) :: dspmmap.c(395) +zcall4_, arg. 4 used inconsistently t_wcspix.c(441) :: t_wcspix.c(525) +zcall4_, arg. 5 used inconsistently t_wcspix.c(441) :: t_wcspix.c(525) +ximalt_, arg. 2 used inconsistently ximtool.c(295) :: ximtool.c(607) +ximalt_, arg. 3 used inconsistently ximtool.c(295) :: ximtool.c(607) +Saving output.... +Cleaning up.... +/bin/rm: No match. +Done. diff --git a/vendor/x11iraf/ximtool/clients.old/doc/Notes b/vendor/x11iraf/ximtool/clients.old/doc/Notes new file mode 100644 index 00000000..da021306 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/doc/Notes @@ -0,0 +1,199 @@ + + +define MAX_WCSLINES 4 + +define SZ_WPIX 6 +define WP_CPTR Memi[$1 ] # cache pointer +define WP_PTABSZ Memi[$1+1] # pixel table size +define WP_SYSTEMS Memi[$1+2] # WCS readout systems +define WP_FORMATS Memi[$1+3] # WCS readout formats + +define SYSTEMS Memi[WP_SYSTEMS($1)+$2-1] # WCS systems per line +define FORMATS Memi[WP_FORMATS($1)+$2-1] # WCS formats per line +define OBJCACHE Memi[WP_CPTR($1)+$2] # object cache + +# Element of an 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_REF Memc[P2C($1+4)] # object reference file + +# Object class definitions. +define IMAGE_CLASS 1 # generic image class +define MEF_CLASS 2 # Mosaic MEF image class +define MULTISPEC_CLASS 3 # multispec data class + +# Class methods. +define LEN_CL 6 # length of class table +define MAX_CL 6 # max supported classes +define SZ_CLNAME 16 # 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_GETDATA cl_table[6,$1] # get object data +define CL_NAME cl_names[1,$1] # class name + +# Class common. +int cl_nclasses # number of defined functions +int cl_table[LEN_CL,MAX_CL] # class table +char cl_names[SZ_CLNAME,MAX_CL] # class names +common /class_com/ cl_nclasses, cl_table, cl_names + + +# Image class data. +define O_IM Memi[$1+2] # image pointer +define O_MW Memi[$1+3] # image wcs pointer +define O_CO Memi[$1+3] # skywcs transform pointer +define O_CT Memi[$1+4] # mwcs transform pointer +define O_ROT Memr[$1+5] # rotation angle +define O_SCALE Memr[$1+6] # plate scale + + + +-------------------------------------------------------------------------------- +ISM Methods: +-------------------------------------------------------------------------------- + + initialize + cache <objid> <ref> + uncache <objid> + wcstran <objid> <x> <y> [[<region-name> <x> <y>] ["NDC" <x> <y>]] + wcslist <objid> + getheader <objid> <template-list> + + +procedure initialize +begin + for (each object in the cache) + uncache object + send startup req to GUI +end + +procedure cache +begin +end + +procedure uncache +begin +end + +procedure wcstran +begin +end + +procedure wcslist +begin +end + +procedure getheader +begin +end + + +-------------------------------------------------------------------------------- +GUI Callbacks +-------------------------------------------------------------------------------- + +proc ism_msg { param old new } { + + set target [lindex $new 0] ;# name of ism module + + switch [lindex $new 0] { + source { source [lindex $new 1] } ;# source Tcl code + alert { Wexec client [lindex $new 1] } ;# alert from ism client + + deliver { set ism [lindex $new 0] ;# determine ISM name + set argv [lrange $new 1 end] ;# get args + set argc [llength $argv] + ${ism}_msg $argc $argv ;# call module + } + } +} ; send ism_msg addCallback ism_msg + + +proc wpix_msg { argc argv } { + + switch [lindex $argv 0] { + startup { wpix_startup } + shutdown { wpix_shutdown } + cache { .... save image name to GUI cache list + } + uncache { .... remove image name from GUI cache list + } + wcstran { .... parse argv for WCS field and update display + } + pixtab { + } + wcslist { + } + wcstype { set type [lindex $argv 1] ;# Set WCS for a line + set line [lindex $argv 2] + send sysWcs$line set label $type + if {$type == "None"} { + send wpWcs$line set on False + } else { + send wpWcs$line set on True + } + setCoordPanelHeight + } + wcsfmt { set fmt [lindex $argv 1] ;# Set fmt for a line + set line [lindex $argv 2] + send fmtWcs$line set label $fmt + } + header { set type [lindex $argv 1] ;# write header text + set text [lindex $argv 2] + switch $type { + imghdr {send hdrText append $text} + wcshdr {send hdrKGText append $text} + wcsinfo {send hdrIGText append $text} + } + } + } ;# end switch +} + +proc wpix_startup args { + global ismEnabled frameCache + + set ismEnabled 1 ;# initialize buttons + send ismToggle set on True + send imageHeader setSensitive True + setCoordPanelSensitivity + + resizeCoordsBox $up_todo ;# resize wcsbox marker + updateCoordsBox + + foreach c [array names frameCache] { ;# initialize local frame cache + if {$c != "0"} { unset frameCache($c) } + } + + catch { ;# update ISM with GUI settings + send wpix set psize $psize + set wcsfmt [string tolower [send wcsFmtMenu get label]] + send wpix set wcsfmt $wcsfmt + if {[send wcsSysAltWCS get on]} { + setAltSystem + } + } +} + +proc wpix_shutdown args { + global ismEnabled + + set ismEnabled 0 + send ismToggle set on False + send imageHeader setSensitive False + setCoordPanelSensitivity + wcsFmtIValue "" + wcsFmtImWCS "" "" "" + wcsFmtAltWCS "" "" "" + resizeCoordsBox 0 +} + + diff --git a/vendor/x11iraf/ximtool/clients.old/doc/README b/vendor/x11iraf/ximtool/clients.old/doc/README new file mode 100644 index 00000000..e69de29b --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/doc/README diff --git a/vendor/x11iraf/ximtool/clients.old/lib/README b/vendor/x11iraf/ximtool/clients.old/lib/README new file mode 100644 index 00000000..e69de29b --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/README diff --git a/vendor/x11iraf/ximtool/clients.old/lib/dspmmap.f b/vendor/x11iraf/ximtool/clients.old/lib/dspmmap.f new file mode 100644 index 00000000..3542286f --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/dspmmap.f @@ -0,0 +1,356 @@ + integer function dspmmp (pmname, refim) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer refim + integer*2 pmname(*) + integer im + integer*2 fname(255 +1) + integer nowhie + integer errcoe + logical streq + integer impmmp + integer dspmip + logical xerpop + logical xerflg + common /xercom/ xerflg + integer sw0001 + integer*2 st0001(6) + integer*2 st0002(4) + integer*2 st0003(4) + save + data st0001 / 69, 77, 80, 84, 89, 0/ + data st0002 / 66, 80, 77, 0/ + data st0003 / 66, 80, 77, 0/ + if (.not.(nowhie (pmname, fname, 255 ) .eq. 0)) goto 110 + dspmmp = (0) + goto 100 +110 continue + if (.not.(streq (fname, st0001))) goto 120 + dspmmp = (0) + goto 100 +120 continue + if (.not.(fname(1) .eq. 33)) goto 130 + call xerpsh + call imgstr (refim, fname(2), fname, 255 ) + if (.not.xerpop()) goto 140 + fname(1) = 0 +140 continue + goto 131 +130 continue + if (.not.(streq (fname, st0002))) goto 150 + call xerpsh + call imgstr (refim, st0003, fname, 255 ) + if (.not.xerpop()) goto 160 + dspmmp = (0) + goto 100 +160 continue +150 continue +131 continue + call xerpsh + im = impmmp (fname, 1 , 0) + if (.not.xerpop()) goto 170 + sw0001=(errcoe()) + goto 180 +190 continue + im = dspmip (fname, refim) + if (xerflg) goto 100 + goto 181 +200 continue + call erract (2 ) + if (xerflg) goto 100 + goto 181 +180 continue + if (sw0001.eq.743) goto 190 + if (sw0001.eq.921) goto 190 + goto 200 +181 continue +170 continue + call xerpsh + call dsmath (im, refim) + if (.not.xerpop()) goto 210 + call erract (3 ) + if (xerflg) goto 100 +210 continue + dspmmp = (im) + goto 100 +100 return + end + integer function dspmip (pmname, refim) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer refim + integer*2 pmname(*) + integer i + integer ndim + integer npix + integer val + integer sp + integer v1 + integer v2 + integer imin + integer imout + integer pm + integer mw + integer data + integer imgnli + integer immap + integer pmnewk + integer impmmo + integer imgl1i + integer mwopem + logical xerflg + common /xercom/ xerflg + save + call smark (sp) + call salloc (v1, 7 , 5) + call salloc (v2, 7 , 5) + call amovkl (int(1), meml(v1), 7 ) + call amovkl (int(1), meml(v2), 7 ) + imin = immap (pmname, 1 , 0) + if (xerflg) goto 100 + pm = pmnewk (imin, 27) + ndim = memi(imin+200 +7) + npix = meml(imin+200 +1+8-1) +110 if (.not.(imgnli (imin, data, meml(v1)) .ne. -2)) goto 111 + do 120 i = 0, npix-1 + val = memi(data+i) + if (.not.(val .lt. 0)) goto 130 + memi(data+i) = 0 +130 continue +120 continue +121 continue + call pmplpi (pm, meml(v2), memi(data), 0, npix, 12 ) + call amovl (meml(v1), meml(v2), ndim) + goto 110 +111 continue + imout = impmmo (pm, imin) + data = imgl1i (imout) + mw = mwopem (imin) + if (xerflg) goto 100 + call mwsavm (mw, imout) + call mwcloe (mw) + call imunmp (imin) + call sfree (sp) + dspmip = (imout) + goto 100 +100 return + end + subroutine dsmath (im, refim) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer im + integer refim + integer i + integer j + integer k + integer l + integer i1 + integer i2 + integer j1 + integer j2 + integer nc + integer nl + integer ncpm + integer nlpm + integer nx + integer val + double precision x1 + double precision x2 + double precision y1 + double precision y2 + double precision lt(6) + double precision lt1(6) + double precision lt2(6) + integer*4 vold(7 ) + integer*4 vnew(7 ) + integer pm + integer pmnew + integer imnew + integer mw + integer ctx + integer cty + integer bufref + integer bufpm + integer imstai + integer plopen + integer mwopem + integer impmmo + integer imgl1i + integer mwsctn + logical pmempy + logical pmliny + logical xerflg + common /xercom/ xerflg + integer*2 st0001(40) + integer*2 st0002(8) + integer*2 st0003(9) + integer*2 st0004(8) + integer*2 st0005(9) + save + integer iyy + data (st0001(iyy),iyy= 1, 8) / 73,109, 97,103,101, 32, 97,110/ + data (st0001(iyy),iyy= 9,16) /100, 32,109, 97,115,107, 32,104/ + data (st0001(iyy),iyy=17,24) / 97,118,101, 32, 97, 32,114,101/ + data (st0001(iyy),iyy=25,32) /108, 97,116,105,118,101, 32,114/ + data (st0001(iyy),iyy=33,40) /111,116, 97,116,105,111,110, 0/ + data st0002 /108,111,103,105, 99, 97,108, 0/ + data (st0003(iyy),iyy= 1, 8) /112,104,121,115,105, 99, 97,108/ + data (st0003(iyy),iyy= 9, 9) / 0/ + data st0004 /108,111,103,105, 99, 97,108, 0/ + data (st0005(iyy),iyy= 1, 8) /112,104,121,115,105, 99, 97,108/ + data (st0005(iyy),iyy= 9, 9) / 0/ + if (.not.(im .eq. 0)) goto 110 + goto 100 +110 continue + nc = meml(refim+200 +1+8-1) + nl = meml(refim+200 +2+8-1) + ncpm = meml(im+200 +1+8-1) + nlpm = meml(im+200 +2+8-1) + pm = imstai (im, 16 ) + if (.not.(pmempy(pm) .and. nc .eq. ncpm .and. nl .eq. nlpm)) + * goto 120 + goto 100 +120 continue + mw = mwopem (im) + if (xerflg) goto 100 + call mwgltd (mw, lt, lt(5), 2) + call mwcloe (mw) + mw = mwopem (refim) + if (xerflg) goto 100 + call mwgltd (mw, lt2, lt2(5), 2) + call mwcloe (mw) + call mwinvd (lt, lt1, 2) + call mwmmud (lt1, lt2, lt, 2) + call mwvmud (lt, lt(5), lt(5), 2) + lt(5) = lt2(5) - lt(5) + lt(6) = lt2(6) - lt(6) + do 130 i = 1, 6 + lt(i) = nint (1d6 * (lt(i)-int(lt(i)))) / 1d6 + int(lt(i)) +130 continue +131 continue + if (.not.(lt(2) .ne. 0. .or. lt(3) .ne. 0.)) goto 140 + call xerror(1, st0001) + if (xerflg) goto 100 +140 continue + if (.not.(lt(1) .eq. 1d0 .and. lt(4) .eq. 1d0 .and. lt(5) .eq. + * 0d0 .and. lt(6) .eq. 0d0)) goto 150 + goto 100 +150 continue + mw = mwopem (im) + if (xerflg) goto 100 + call mwsltd (mw, lt, lt(5), 2) + ctx = mwsctn (mw, st0002, st0003, 1) + cty = mwsctn (mw, st0004, st0005, 2) + pmnew = plopen(0) + if (xerflg) goto 100 + call plssie(pmnew, 2, meml(refim+200 +1+8-1) , 27) + imnew = impmmo (pmnew, 0) + bufref = imgl1i (imnew) + call mwctrd (ctx, 1-0.5d0, x1, 1) + call mwctrd (ctx, nc+0.5d0, x2, 1) + i1 = max (1, nint(min(x1,x2)+1d-5)) + i2 = min (ncpm, nint(max(x1,x2)-1d-5)) + call mwctrd (cty, 1-0.5d0, y1, 1) + call mwctrd (cty, nl+0.5d0, y2, 1) + j1 = max (1, nint(min(y1,y2)+1d-5)) + j2 = min (nlpm, nint(max(y1,y2)-1d-5)) + if (.not.(i1 .le. i2 .and. j1 .le. j2)) goto 160 + nx = i2 - i1 + 1 + call xmallc(bufpm, nx, 4) + call xmallc(bufref, nc, 4) + vold(1) = i1 + vnew(1) = 1 + do 170 j = 1, nl + call mwctrd (cty, j-0.5d0, y1, 1) + call mwctrd (cty, j+0.5d0, y2, 1) + j1 = max (1, nint(min(y1,y2)+1d-5)) + j2 = min (nlpm, nint(max(y1,y2)-1d-5)) + if (.not.(j2 .lt. j1)) goto 180 + goto 170 +180 continue + vnew(2) = j + call aclri (memi(bufref), nc) + do 190 l = j1, j2 + vold(2) = l + if (.not.(.not.pmliny (pm, vold))) goto 200 + goto 190 +200 continue + call pmglpi (pm, vold, memi(bufpm), 0, nx, 0) + do 210 i = 1, nc + call mwctrd (ctx, i-0.5d0, x1, 1) + call mwctrd (ctx, i+0.5d0, x2, 1) + i1 = max (1, nint(min(x1,x2)+1d-5)) + i2 = min (ncpm, nint(max(x1,x2)-1d-5)) + if (.not.(i2 .lt. i1)) goto 220 + goto 210 +220 continue + val = memi(bufref+i-1) + do 230 k = i1-vold(1), i2-vold(1) + val = max (val, memi(bufpm+k)) +230 continue +231 continue + memi(bufref+i-1) = val +210 continue +211 continue +190 continue +191 continue + call pmplpi (pmnew, vnew, memi(bufref), 0, nc, 12 ) +170 continue +171 continue + call xmfree(bufref, 4) + call xmfree(bufpm, 4) +160 continue + call mwcloe (mw) + call imunmp (im) + im = imnew + call imseti (im, 16 , pmnew) +100 return + end +c pmliny pm_linenotempty +c mwmmud mw_mmuld +c errcoe errcode +c mwsltd mw_sltermd +c mwinvd mw_invertd +c impmmo im_pmmapo +c plssie pl_ssize +c mwctrd mw_ctrand +c pmempy pm_empty +c mwvmud mw_vmuld +c dsmath ds_match +c plopen pl_open +c mwsavm mw_saveim +c mwopem mw_openim +c imunmp imunmap +c mwsctn mw_sctran +c impmmp im_pmmap +c dspmip ds_pmimmap +c dspmmp ds_pmmap +c imstai imstati +c nowhie nowhite +c mwcloe mw_close +c pmnewk pm_newmask +c mwgltd mw_gltermd diff --git a/vendor/x11iraf/ximtool/clients.old/lib/dspmmap.x b/vendor/x11iraf/ximtool/clients.old/lib/dspmmap.x new file mode 100644 index 00000000..621f0372 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/dspmmap.x @@ -0,0 +1,244 @@ +include <mach.h> +include <ctype.h> +include <error.h> +include <imhdr.h> +include <imset.h> +include <pmset.h> +include <syserr.h> + + +# DS_PMMAP -- Open a pixel mask READ_ONLY. +# +# Open the pixel mask. If a regular image is specified convert it to +# a pixel mask. Match the mask to the reference image based on the +# physical coordinates. A null filename is allowed and returns NULL. + +pointer procedure ds_pmmap (pmname, refim) + +char pmname[ARB] #I Pixel mask name +pointer refim #I Reference image pointer + +pointer im +char fname[SZ_FNAME] +int nowhite(), errcode() +bool streq() +pointer im_pmmap(), ds_pmimmap() +errchk ds_pmimmap, ds_match + +begin + if (nowhite (pmname, fname, SZ_FNAME) == 0) + return (NULL) + if (streq (fname, "EMPTY")) + return (NULL) + if (fname[1] == '!') { + iferr (call imgstr (refim, fname[2], fname, SZ_FNAME)) + fname[1] = EOS + } else if (streq (fname, "BPM")) { + iferr (call imgstr (refim, "BPM", fname, SZ_FNAME)) + return (NULL) + } + + iferr (im = im_pmmap (fname, READ_ONLY, NULL)) { + switch (errcode()) { + case SYS_FOPNNEXFIL, SYS_PLBADSAVEF: + im = ds_pmimmap (fname, refim) + default: + call erract (EA_ERROR) + } + } + + iferr (call ds_match (im, refim)) + call erract (EA_WARN) + + return (im) +end + + +# DS_PMIMMAP -- Open a pixel mask from a non-pixel list image. +# Return error if the image cannot be opened. + +pointer procedure ds_pmimmap (pmname, refim) + +char pmname[ARB] #I Image name +pointer refim #I Reference image pointer + +int i, ndim, npix, val +pointer sp, v1, v2, im_in, im_out, pm, mw, data + +int imgnli() +pointer immap(), pm_newmask(), im_pmmapo(), imgl1i(), mw_openim() +errchk immap, mw_openim + +begin + call smark (sp) + call salloc (v1, IM_MAXDIM, TY_LONG) + call salloc (v2, IM_MAXDIM, TY_LONG) + + call amovkl (long(1), Meml[v1], IM_MAXDIM) + call amovkl (long(1), Meml[v2], IM_MAXDIM) + + im_in = immap (pmname, READ_ONLY, 0) + pm = pm_newmask (im_in, 27) + + ndim = IM_NDIM(im_in) + npix = IM_LEN(im_in,1) + + while (imgnli (im_in, data, Meml[v1]) != EOF) { + do i = 0, npix-1 { + val = Memi[data+i] + if (val < 0) + Memi[data+i] = 0 + } + call pmplpi (pm, Meml[v2], Memi[data], 0, npix, PIX_SRC) + call amovl (Meml[v1], Meml[v2], ndim) + } + + im_out = im_pmmapo (pm, im_in) + data = imgl1i (im_out) # Force I/O to set header + mw = mw_openim (im_in) # Set WCS + call mw_saveim (mw, im_out) + call mw_close (mw) + + call imunmap (im_in) + call sfree (sp) + return (im_out) +end + + +# DS_MATCH -- Set the pixel mask to match the reference image. +# This matches sizes and physical coordinates and allows the +# original mask to be smaller or larger than the reference image. +# Subsequent use of the pixel mask can then work in the logical +# coordinates of the reference image. The mask values are the maximum +# of the mask values which overlap each reference image pixel. +# A null input returns a null output. + +procedure ds_match (im, refim) + +pointer im #U Pixel mask image pointer +pointer refim #I Reference image pointer + +int i, j, k, l, i1, i2, j1, j2, nc, nl, ncpm, nlpm, nx, val +double x1, x2, y1, y2, lt[6], lt1[6], lt2[6] +long vold[IM_MAXDIM], vnew[IM_MAXDIM] +pointer pm, pmnew, imnew, mw, ctx, cty, bufref, bufpm + +int imstati() +pointer pm_open(), mw_openim(), im_pmmapo(), imgl1i(), mw_sctran() +bool pm_empty(), pm_linenotempty() +errchk pm_open, mw_openim + +begin + if (im == NULL) + return + + # Set sizes. + nc = IM_LEN(refim,1) + nl = IM_LEN(refim,2) + ncpm = IM_LEN(im,1) + nlpm = IM_LEN(im,2) + + # If the mask is empty and the sizes are the same then it does not + # matter if the two are actually matched in physical coordinates. + pm = imstati (im, IM_PMDES) + if (pm_empty(pm) && nc == ncpm && nl == nlpm) + return + + # Compute transformation between reference (logical) coordinates + # and mask (physical) coordinates. + + mw = mw_openim (im) + call mw_gltermd (mw, lt, lt[5], 2) + call mw_close (mw) + + mw = mw_openim (refim) + call mw_gltermd (mw, lt2, lt2[5], 2) + call mw_close (mw) + + # Combine lterms. + call mw_invertd (lt, lt1, 2) + call mw_mmuld (lt1, lt2, lt, 2) + call mw_vmuld (lt, lt[5], lt[5], 2) + lt[5] = lt2[5] - lt[5] + lt[6] = lt2[6] - lt[6] + do i = 1, 6 + lt[i] = nint (1D6 * (lt[i]-int(lt[i]))) / 1D6 + int(lt[i]) + + # Check for a rotation. For now don't allow any rotation. + if (lt[2] != 0. || lt[3] != 0.) + call error (1, "Image and mask have a relative rotation") + + # Check for an exact match. + if (lt[1] == 1D0 && lt[4] == 1D0 && lt[5] == 0D0 && lt[6] == 0D0) + return + + # Set reference to mask coordinates. + mw = mw_openim (im) + call mw_sltermd (mw, lt, lt[5], 2) + ctx = mw_sctran (mw, "logical", "physical", 1) + cty = mw_sctran (mw, "logical", "physical", 2) + + # Create a new pixel mask of the required size and offset. + # Do dummy image I/O to set the header. + pmnew = pm_open (NULL) + call pm_ssize (pmnew, 2, IM_LEN(refim,1), 27) + imnew = im_pmmapo (pmnew, NULL) + bufref = imgl1i (imnew) + + # Compute region of mask overlapping the reference image. + call mw_ctrand (ctx, 1-0.5D0, x1, 1) + call mw_ctrand (ctx, nc+0.5D0, x2, 1) + i1 = max (1, nint(min(x1,x2)+1D-5)) + i2 = min (ncpm, nint(max(x1,x2)-1D-5)) + call mw_ctrand (cty, 1-0.5D0, y1, 1) + call mw_ctrand (cty, nl+0.5D0, y2, 1) + j1 = max (1, nint(min(y1,y2)+1D-5)) + j2 = min (nlpm, nint(max(y1,y2)-1D-5)) + + # Set the new mask values to the maximum of all mask values falling + # within each reference pixel in the overlap region. + if (i1 <= i2 && j1 <= j2) { + nx = i2 - i1 + 1 + call malloc (bufpm, nx, TY_INT) + call malloc (bufref, nc, TY_INT) + vold[1] = i1 + vnew[1] = 1 + do j = 1, nl { + call mw_ctrand (cty, j-0.5D0, y1, 1) + call mw_ctrand (cty, j+0.5D0, y2, 1) + j1 = max (1, nint(min(y1,y2)+1D-5)) + j2 = min (nlpm, nint(max(y1,y2)-1D-5)) + if (j2 < j1) + next + + vnew[2] = j + call aclri (Memi[bufref], nc) + do l = j1, j2 { + vold[2] = l + if (!pm_linenotempty (pm, vold)) + next + call pmglpi (pm, vold, Memi[bufpm], 0, nx, 0) + do i = 1, nc { + call mw_ctrand (ctx, i-0.5D0, x1, 1) + call mw_ctrand (ctx, i+0.5D0, x2, 1) + i1 = max (1, nint(min(x1,x2)+1D-5)) + i2 = min (ncpm, nint(max(x1,x2)-1D-5)) + if (i2 < i1) + next + val = Memi[bufref+i-1] + do k = i1-vold[1], i2-vold[1] + val = max (val, Memi[bufpm+k]) + Memi[bufref+i-1] = val + } + } + call pmplpi (pmnew, vnew, Memi[bufref], 0, nc, PIX_SRC) + } + call mfree (bufref, TY_INT) + call mfree (bufpm, TY_INT) + } + + call mw_close (mw) + call imunmap (im) + im = imnew + call imseti (im, IM_PMDES, pmnew) +end diff --git a/vendor/x11iraf/ximtool/clients.old/lib/idxstr.f b/vendor/x11iraf/ximtool/clients.old/lib/idxstr.f new file mode 100644 index 00000000..ac16febf --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/idxstr.f @@ -0,0 +1,44 @@ + integer function idxstr (index, outstr, maxch, dict) + integer index + integer maxch + integer*2 outstr(*) + integer*2 dict(*) + integer i + integer len + integer start + integer count + integer xstrln + save + outstr(1) = 0 + if (.not.(dict(1) .eq. 0)) goto 110 + idxstr = (0) + goto 100 +110 continue + count = 1 + len = xstrln(dict) + start = 2 +120 if (.not.(count .lt. index)) goto 122 + if (.not.(dict(start) .eq. dict(1))) goto 130 + count = count + 1 +130 continue + if (.not.(start .eq. len)) goto 140 + idxstr = (0) + goto 100 +140 continue +121 start = start + 1 + goto 120 +122 continue + i = start +150 if (.not.(dict(i) .ne. 0 .and. dict(i) .ne. dict(1))) goto 152 + if (.not.(i - start + 1 .gt. maxch)) goto 160 + goto 152 +160 continue + outstr(i - start + 1) = dict(i) +151 i = i + 1 + goto 150 +152 continue + outstr(i - start + 1) = 0 + idxstr = (count) + goto 100 +100 return + end diff --git a/vendor/x11iraf/ximtool/clients.old/lib/idxstr.x b/vendor/x11iraf/ximtool/clients.old/lib/idxstr.x new file mode 100644 index 00000000..7b055658 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/idxstr.x @@ -0,0 +1,54 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + + +# IDXSTR -- Search a dictionary string for a given string index number. +# This is the opposite function of strdic(), that returns the index for +# given string. The entries in the dictionary string are separated by +# a delimiter character which is the first character of the dictionary +# string. The index of the string found is returned as the function value. +# Otherwise, if there is no string for that index, a zero is returned. + +int procedure idxstr (index, outstr, maxch, dict) + +int index #i String index +char outstr[ARB] #o Output string as found in dictionary +int maxch #i Maximum length of output string +char dict[ARB] #i Dictionary string + +int i, len, start, count + +int strlen() + +begin + # Clear the output string. + outstr[1] = EOS + + # Return if the dictionary is not long enough. + if (dict[1] == EOS) + return (0) + + # Initialize the counters. + count = 1 + len = strlen (dict) + + # Search the dictionary string. This loop only terminates + # successfully if the index is found. Otherwise the procedure + # returns with and error condition. + for (start = 2; count < index; start = start + 1) { + if (dict[start] == dict[1]) + count = count + 1 + if (start == len) + return (0) + } + + # Extract the output string from the dictionary. + for (i = start; dict[i] != EOS && dict[i] != dict[1]; i = i + 1) { + if (i - start + 1 > maxch) + break + outstr[i - start + 1] = dict[i] + } + outstr[i - start + 1] = EOS + + # Return index for output string. + return (count) +end diff --git a/vendor/x11iraf/ximtool/clients.old/lib/mkpkg b/vendor/x11iraf/ximtool/clients.old/lib/mkpkg new file mode 100644 index 00000000..3c6a6c14 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/mkpkg @@ -0,0 +1,17 @@ +# Make the ISM Client tasks. + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + @skywcs + idxstr.x + reopen.x <config.h> <fio.com> <fio.h> + dspmmap.x <ctype.h> <error.h> <imhdr.h> <imset.h> \ + <mach.h> <pmset.h> + wcsgfterm.x + ximtool.x <config.h> <mach.h> <xwhen.h> + ; + diff --git a/vendor/x11iraf/ximtool/clients.old/lib/reopen.f b/vendor/x11iraf/ximtool/clients.old/lib/reopen.f new file mode 100644 index 00000000..f7a1c456 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/reopen.f @@ -0,0 +1,70 @@ + integer function reopen (fd, mode) + integer fd + integer mode + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer newfp + integer ffp + integer newfd + integer fgetfd + integer*4 boffst(4096 ) + integer bufptr(4096 ) + integer buftop(4096 ) + integer iop(4096 ) + integer itop(4096 ) + integer otop(4096 ) + integer fiodes(4096 ) + integer fflags(4096 ) + integer redird(4096 ) + integer zdev(150 ) + integer nextdv + integer fp + integer*2 pathne(511 +1) + logical xerflg + common /xercom/ xerflg + common /fiocom/ boffst, bufptr, buftop, iop, itop, otop, fiodes, + *fflags, redird, zdev, nextdv, fp, pathne + save + ffp = fiodes(fd) + if (.not.(fd .le. 0 .or. ffp .eq. 0)) goto 110 + call syserr (733) + if (xerflg) goto 100 +110 continue + if (.not.(memi(ffp+1) .eq. 1 .and. mode .ne. 1 )) goto 120 + call filerr (memc((((ffp+20+(10+256))-1)*2+1)) , 750) +120 continue + if (.not.(memi(ffp+2) .ne. 12)) goto 130 + call filerr (memc((((ffp+20+(10+256))-1)*2+1)) , 751) +130 continue + newfd = fgetfd (memc((((ffp+20+(10+256))-1)*2+1)) , mode, 12) + newfp = fiodes(newfd) + memi(newfp+3) = memi(ffp+3) + memi(newfp+4) = memi(ffp+4) + memi(newfp) = memi(ffp) + if (.not.(memi(ffp+18) .eq. (ffp+20) )) goto 140 + call xmallc(memi(ffp+18) , (10+256), 10 ) + if (xerflg) goto 100 + call amovi (memi((ffp+20) ), memi(memi(ffp+18) ), (10+256)) +140 continue + memi(memi(ffp+18) ) = memi(memi(ffp+18) ) + 1 + memi(newfp+18) = memi(ffp+18) + if (.not.(mode .eq. 4)) goto 150 + call xfseek(newfd, -2) + if (xerflg) goto 100 +150 continue + reopen = (newfd) + goto 100 +100 return + end +c nextdv next_dev +c boffst boffset +c redird redir_fd +c pathne pathname diff --git a/vendor/x11iraf/ximtool/clients.old/lib/reopen.x b/vendor/x11iraf/ximtool/clients.old/lib/reopen.x new file mode 100644 index 00000000..59ddba30 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/reopen.x @@ -0,0 +1,55 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <config.h> +include <syserr.h> +include <fio.h> + +# REOPEN -- Reopen a binary file. Used to gain two or more independent +# sets of buffers to access a binary file. No protection against two +# file descriptors trying to write to the same part of the file at the +# same time, which may result in loss of data. The file descriptors and +# buffers of reopened files are independent, but all files accessing the +# same channel share the same channel descriptor (necessary to synchronize +# i/o requests and to maintain a unique file size parameter). + +int procedure reopen (fd, mode) + +int fd, mode +pointer newfp, ffp +int newfd, fgetfd() +errchk syserr, malloc, seek +include <fio.com> + +begin + ffp = fiodes[fd] + if (fd <= 0 || ffp == NULL) + call syserr (SYS_FILENOTOPEN) + + if (FMODE(ffp) == READ_ONLY && mode != READ_ONLY) + call filerr (FNAME(ffp), SYS_FREOPNMODE) + if (FTYPE(ffp) != BINARY_FILE) + call filerr (FNAME(ffp), SYS_FREOPNTYPE) + + newfd = fgetfd (FNAME(ffp), mode, BINARY_FILE) + newfp = fiodes[newfd] + + FDEV(newfp) = FDEV(ffp) + FBUFSIZE(newfp) = FBUFSIZE(ffp) + FCHAN(newfp) = FCHAN(ffp) + + # If this is the first reopen, allocate space for a separate channel + # descriptor and copy the channel descriptor from the original file. + + if (FCD(ffp) == FLCD(ffp)) { + call malloc (FCD(ffp), LEN_CHANDES, TY_STRUCT) + call amovi (Memi[FLCD(ffp)], Memi[FCD(ffp)], LEN_CHANDES) + } + + FREFCNT(ffp) = FREFCNT(ffp) + 1 # bump ref count + FCD(newfp) = FCD(ffp) + + if (mode == APPEND) + call seek (newfd, EOFL) + + return (newfd) +end diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/README b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/README new file mode 100644 index 00000000..d15ab738 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/README @@ -0,0 +1,302 @@ + SKYWCS: The Sky Coordinates Package + +1. Introduction + + The skywcs package contains a simple set of routines for doing managing sky +coordinate information and for transforming from one sky coordinate system to +another. The sky coordinate system is defined either by a system name, e.g. +"J2000", "galactic, etc., or by an image system name, e.g. "dev$ypix" or +"dev$ypix world". + + The skywcs routine are layered on the Starlink Positional Astronomy library +SLALIB which is installed in the IRAF MATH package. Type "help slalib option= +sys" for more information about SLALIB. + + +2. The Interface Routines + +The package prefix is sk. The interface routines are listed below. + + stat = sk_decwcs (ccsystem, mw, coo, imcoo) + stat = sk_decwstr (ccsystem, coo, imcoo) + stat = sk_decim (im, wcs, mw, coo) + sk_enwcs (coo, ccsystem, maxch) + newcoo = sk_copy (coo) + sk_iiprint (label, imagesys, mw, coo) + sk_iiwrite (fd, label, imagesys, mw, coo) +[id]val = sk_stat[id] (coo, param) + sk_stats (coo, param, str, maxch) + sk_set[id] (coo, param, [id]val) + sk_sets (coo, param, str) + sk_ultran (incoo, outcoo, ilng, ilat, olng, olat, npts) + sk_lltran (incoo, outoo, ilng, ilat, ipmlng, ipmlat, px, rv, + olng, olat) + sk_equatorial (incoo, outcoo, ilng, ilat, ipmlng, ipmlat, px, + rv, olng, olat) + sk_saveim (coo, mw, im) + sk_close (coo) + + +3. Notes + + An "include <pkg/skywcs.h>" statement must be included in the calling +program to make the skywcs package parameter definitions visible to the calling +program. + + An "-lxtools -lslalib" must be included in the calling program link line +to link in the skywcs and the slalib routines. + + The sky coordinate descriptor is created with a call to one of the +sk_decwcs, sk_decwstr, or sk_imwcs routines. If the source of the sky +coordinate descriptor is an image then an IRAF MWCS descriptor will be returned +with the sky oordinate descriptor. The sky coordinate descriptor is freed with a +call to sk_close. A separate call to mw_close must be made to free the MWCS +descriptor if one was allocated. + + By default the main skywcs coordinate transformation routine sk_ultran +assumes that the input and output sky coordinates are in hours and degrees +if the input and output coordinate systems are equatorial, otherwise the +coordinates are assumed to be in degrees and degrees. The default input and +output sky coordinate units can be reset with calls to sk_seti. Two lower level +coordinate transformations for handling proper motions sk_lltran and +sk_equatorial are also available. These routines that the input and output +coordinates and proper motions are in radians. + + Calling programs working with both sky coordinate and MWCS descriptors +need to be aware that the MWCS routines assume that all sky coordinates +must be input in degrees and will be output in degrees and adjust their +code accordingly. + + The skywcs routine sk_saveim can be used to update an image header. + + +3. Examples + +Example 1: Convert from B1950 coordinates to J2000 coordinates. + + include <skywcs.h> + + .... + + # Open input coordinate system. + instat = sk_decwstr ("B1950", incoo, NULL) + if (instat == ERR) { + call sk_close (incoo) + return + } + + # Open output coordinate system. + outstat = sk_decwstr ("J2000", outcoo, NULL) + if (outstat == ERR) { + call sk_close (outcoo) + return + } + + # Do the transformation assuming the input coordinates are in hours + # and degrees. The output coordinates will be in hours and degrees + # as well. + call sk_ultran (incoo, outcoo, rain, decin, raout, decout, npts) + + # Close the coordinate descriptors. + call sk_close (incoo) + call sk_close (outcoo) + + ... + + +Example 2: Repeat example 1 but convert to galactic coordinates. + + include <skywcs.h> + + .... + + # Open the input coordinate system. + instat = sk_decwstr ("B1950", incoo, NULL) + if (instat == ERR) { + call sk_close (incoo) + return + } + + # Open the output coordinate system. + outstat = sk_decwstr ("galactic", outcoo, NULL) + if (outstat == ERR) { + call sk_close (outcoo) + return + } + + # Dd the transformation assuming the input coordinates are in hours and + # degrees. The output coordinates will be in degrees and degrees. + call sk_ultran (incoo, outcoo, rain, decin, raout, decout, npts) + + # Close the coordinate descriptors. + call sk_close (incoo) + call sk_close (outcoo) + + ... + +Example 3: Convert a grid of pixel coordinates in the input image to the +equivalent pixel coordinate in the output image using the image world +coordinate systems to connect the two. + + include <skywcs.h> + + .... + + # Mwref will be defined because the input system is an image. + refstat = sk_decwcs ("refimage logical", mwref, refcoo, NULL) + if (refstat == ERR || mwref == NULL) { + if (mwref != NULL) + call mw_close (mwref) + call sk_close (refcoo) + return + } + + # Set the reference coordinate descriptor so it expects input in degrees + # and degrees. + call sk_seti (refcoo, S_NLNGUNUTS, SKY_DEGREES) + call sk_seti (refcoo, S_NLATUNUTS, SKY_DEGREES) + + # Mwout will be defined because the output system is an image. + outstat = sk_decwcs ("image logical", mwout, outcoo, NULL) + if (outstat == ERR || mwout == NULL) { + if (mwout != NULL) + call mw_close (mwout) + call sk_close (outcoo) + call mw_close (mwref) + call sk_close (refcoo) + return + } + + # Set the output coordinate descriptor so it will output coordinates + # in degrees and degrees. + call sk_seti (outcoo, S_NLNGUNUTS, SKY_DEGREES) + call sk_seti (outcoo, S_NLATUNUTS, SKY_DEGREES) + + # Compute pixel grid in refimage and store coordinate in the arrays + # xref and yref. + npts = 0 + do j = 1, IM_LEN(im,2), 100 { + do i = 1, IM_LEN(im,1), 100 { + npts = npts + 1 + xref[npts] = i + yref[npts] = j + } + } + + # Convert xref and yref to celestial coordinates raref and decref using + # mwref. The output coordinates will be in degrees and degrees. + ctref = mw_sctran (mwref, "logical", "world", 03B) + do i = 1, npts + call mw_c2trand (ctref, xref[i], yref[i], raref[i], decref[i]) + call ct_free (ctref) + + # Convert the reference celestial coordinates to the output celestial + # coordinate system using the coordinate descriptors. + call sk_ultran (refcoo, outcoo, raref, decref, raout, decout, npts) + + # Convert the output celestial coordinates to pixel coordinates in + # the other image using mwout. + ctout = mw_sctran (mwout, "world", "logical", 03B) + do i = 1, npts + call mw_c2trand (ctout, raout[i], decout[i], xout[i], yout[i]) + call ct_free (ctout) + + # Print the input and output pixel coordinates. + do i = 1, npts { + call printf ("%10.3f %10.3f %10.3f %10.3f\n") + call pargd (xref[i]) + call pargd (yref[i]) + call pargd (xout[i]) + call pargd (yout[i]) + } + + # Tidy up. + call mw_close (mwref) + call mw_close (mwout) + call sk_close (refcoo) + call sk_close (outcoo) + + +Example 4: Convert a 2D image with an J2000 tangent plane projection wcs to the +equivalent galactic wcs. The transformation requires a shift in origin and a +rotation. Assume that the ra axis is 1 and the dec axis is 2. The details of +how to compute the rotation are not shown here. See the imcctran task for +details. + + include <mwset.h> + include <skywcs.h> + + ... + + # Open image. + im = immap (image, READ_WRITE, 0) + + # Open the image coordinate system. + instat = sk_decim (im, "logical", mwin, cooin) + if (instat == ERR || mwin == NULL) { + ... + call sk_close (cooin) + ... + } + + # Get the dimensions of the mwcs descriptor. This should be 2. + ndim = mw_ndim (mwin, MW_NPHYSDIM) + + # Get the default coordinates to degrees and degreees. + call sk_seti (cooin, S_NLNGUNITS, SKY_DEGREES) + call sk_seti (cooin, S_NATGUNITS, SKY_DEGREES) + + # Open the output coordinate system. Mwout is NULL because this system + # is not an image. + outstat = sk_decwstr ("galactic", mwout, cooout, cooin) + if (outstat == ERR) { + ... + call sk_close (outstat) + ... + } + + # Make a copy of the mwcs descriptor. + mwout = mw_newcopy (mwin) + + # Allocate space for the r and w vectors and cd matrix. + call malloc (r, ndim, TY_DOUBLE) + call malloc (w, ndim, TY_DOUBLE) + call malloc (cd, ndim * ndim, TY_DOUBLE) + call malloc (newcd, ndim * ndim, TY_DOUBLE) + + # Assume for simplicty that the MWCS LTERM is the identify transform. + # so we don't have to worry about it. Get the WTERM which consists + # of r the reference point in pixels, w the reference point in degrees, + # and the cd matrix in degrees per pixel. + call mw_gwtermd (mwin, Memd[r], Memd[w], Memd[cd], ndim) + + # Convert the world coordinates zero point. The pixel zero point + # remains the same. + tilng = Memd[w] + tilat = Memd[w+1] + call sk_ultran (incoo, outcoo, tilng, tilat, tolng, tolat, 1) + Memd[w] = tolng + Memd[w+1] = tolat + + # Figure out how much to rotate the coordinate system and edit the + # compute a new CD matrix. Call it newcd. + ... + + # Enter the new CD matrix and zero point. + call mw_swterm (mwout, Memd[r], Memd[w], Memd[newcd], ndim) + + # Update the header. + call sk_saveim (cooout, mwout, im) + call mw_saveim (mwout, im) + ... + + # Tidy up. + call mfree (r, TY_DOUBLE) + call mfree (w, TY_DOUBLE) + call mfree (cd, TY_DOUBLE) + call mfree (newcd, TY_DOUBLE) + call mw_close (mwin) + call mw_close (mwout) + call sk_close (cooin) + call sk_close (cooout) + call imunmap (im) diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/ccsystems.hlp b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/ccsystems.hlp new file mode 100644 index 00000000..e812fc8d --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/ccsystems.hlp @@ -0,0 +1,134 @@ +.help ccsystems Mar00 Skywcs +.ih +NAME +ccsystems -- list and describe the supported sky coordinate systems +.ih +USAGE +help ccsystems + +.ih +SKY COORDINATE SYSTEMS + +The sky package supports the equatorial ("fk4", "fk4-noe", "fk5", "icrs"), +ecliptic, galactic, and supergalactic celestial coordinate systems. In most +cases and unless otherwise noted users can input their coordinates in +any one of these systems as long as they specify the coordinate system +correctly. + +Considerable flexibility is permitted in how the coordinate systems are +specified, e.g. J2000.0, j2000.0, 2000.0, fk5, fk5 J2000, and fk5 2000.0 +all specify the mean place post-IAU 1976 or FK5 system. Missing equinox and +epoch fields assume reasonable defaults. In most cases the +systems of most interest to users are are "icrs", "j2000", and "b1950" +which stand for the ICRS J2000.0, FK5 J2000.0 and FK4 B1950.0 celestial +coordinate systems respectively. The full set of options are listed below: + +.ls equinox [epoch] +The equatorial mean place post-IAU 1976 (FK5) system if equinox is a +Julian epoch, e.g. J2000.0 or 2000.0, or the equatorial mean place +pre-IAU 1976 system (FK4) if equinox is a Besselian epoch, e.g. B1950.0 +or 1950.0. Julian equinoxes are prefixed by a J or j, Besselian equinoxes +by a B or b. Equinoxes without the J / j or B / b prefix are treated as +Besselian epochs if they are < 1984.0, Julian epochs if they are >= 1984.0. +Epoch is the epoch of the observation and may be a Julian +epoch, a Besselian epoch, or a Julian date. Julian epochs +are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to the epoch type of +equinox if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. If undefined epoch defaults to equinox. +.le +.ls icrs [equinox] [epoch] +The International Celestial Reference System where equinox is +a Julian or Besselian epoch e.g. J2000.0 or B1980.0. +Equinoxes without the J / j or B / b prefix are treated as Julian epochs. +The default value of equinox is J2000.0. +Epoch is a Besselian epoch, a Julian epoch, or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. If undefined epoch defaults to equinox. +.le +.ls fk5 [equinox] [epoch] +The equatorial mean place post-IAU 1976 (FK5) system where equinox is +a Julian or Besselian epoch e.g. J2000.0 or B1980.0. +Equinoxes without the J / j or B / b prefix are treated as Julian epochs. +The default value of equinox is J2000.0. +Epoch is a Besselian epoch, a Julian epoch, or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. If undefined epoch defaults to equinox. +.le +.ls fk4 [equinox] [epoch] +The equatorial mean place pre-IAU 1976 (FK4) system where equinox is a +Besselian or Julian epoch e.g. B1950.0 or J2000.0, +and epoch is the Besselian epoch, the Julian epoch, or the Julian date of the +observation. +Equinoxes without the J / j or B / b prefix are treated +as Besselian epochs. The default value of equinox is B1950.0. Epoch +is a Besselian epoch, a Julian epoch, or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. If undefined epoch defaults to equinox. +.le +.ls noefk4 [equinox] [epoch] +The equatorial mean place pre-IAU 1976 (FK4) system but without the E-terms +where equinox is a Besselian or Julian epoch e.g. B1950.0 or J2000.0, +and epoch is the Besselian epoch, the Julian epoch, or the Julian date of the +observation. +Equinoxes without the J / j or B / b prefix are treated +as Besselian epochs. The default value of equinox is B1950.0. +Epoch is a Besselian epoch, a Julian epoch, or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian day. If undefined epoch defaults to equinox. +.le +.ls apparent epoch +The equatorial geocentric apparent place post-IAU 1976 system where +epoch is the epoch of observation. +Epoch is a Besselian epoch, a Julian epoch or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian +epochs if the epoch value < 1984.0, Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. +.le +.ls ecliptic epoch +The ecliptic coordinate system where epoch is the epoch of observation. +Epoch is a Besselian epoch, a Julian epoch, or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian epochs +if the epoch values < 1984.0, Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian day. +.le +.ls galactic [epoch] +The IAU 1958 galactic coordinate system. +Epoch is a Besselian epoch, a Julian epoch or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian +epochs if the epoch value < 1984.0, Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. The default value of epoch is B1950.0. +.le +.ls supergalactic [epoch] +The deVaucouleurs supergalactic coordinate system. +Epoch is a Besselian epoch, a Julian epoch or a Julian date. +Julian epochs are prefixed by a J or j, Besselian epochs by a B or b. +Epochs without the J / j or B / b prefix default to Besselian +epochs if the epoch value < 1984.0, Julian epochs +if the epoch value <= 3000.0, otherwise epoch is interpreted as +a Julian date. The default value of epoch is B1950.0. +.le + +Fields enclosed in [] are optional with the defaults as described. The epoch +field for the "icrs" , "fk5", "galactic", and "supergalactic" coordinate +systems is only used if the input coordinates are in the equatorial fk4, +noefk4, fk5, or icrs systems and proper motions are used to transform from +coordinate system to another. + +.ih +SEE ALSO +.endhelp diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skclose.hlp b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skclose.hlp new file mode 100644 index 00000000..191b08b5 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skclose.hlp @@ -0,0 +1,23 @@ +.help skclose Mar00 Skywcs +.ih +NAME +skclose -- free the sky coordinate descriptor +.ih +SYNOPSIS +call sk_close (coo) + +.nf +pointer coo # the sky coordinate descriptor +.fi +.ih +ARGUMENTS +.ls coo +The sky coordinate descriptor to be freed. +.le +.ih +DESCRIPTION +Sk_close frees a previously allocated sky coordinate descriptor. +.ih +SEE ALSO +skdecwcs, skdecwstr, skdecim, skcopy +.endhelp diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skcopy.hlp b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skcopy.hlp new file mode 100644 index 00000000..68219c0d --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skcopy.hlp @@ -0,0 +1,24 @@ +.help skcopy Mar00 Skywcs +.ih +NAME +skcopy -- copy a sky coordinate descriptor +.ih +SYNOPSIS +newcoo = sk_copy (coo) + +.nf +pointer coo # the sky coordinate descriptor +.fi +.ih +ARGUMENTS +.ls coo +The sky coordinate descriptor to be copied. +.le +.ih +DESCRIPTION +Sk_copy is a pointer function which returns a copy of the input sky coordinate +descriptor as its function value. +.ih +SEE ALSO +skdecwcs, skdecwstr, skdecim, skclose +.endhelp diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skdecim.hlp b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skdecim.hlp new file mode 100644 index 00000000..c8f7b2e7 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skdecim.hlp @@ -0,0 +1,55 @@ +.help skdecim Mar00 Skywcs +.ih +NAME +skdecim -- open a sky coordinate descriptor using an image descriptor +.ih +SYNOPSIS +stat = sk_decim (im, mw, coo, imcoo) + +.nf +pointer im # the input image descriptor +pointer mw # the output mwcs descriptor +pointer coo # the output sky coordinate descriptor +pointer imcoo # the input image sky coordinate descriptor +.fi +.ih +ARGUMENTS +.ls im +The input image descriptor. +.le +.ls mw +The output mwcs descriptor. A NULL value for mw is returned if the image +world coordinate system cannot be read. +.le +.ls coo +The output sky coordinate descriptor. +.le +.ls imcoo +The parent image sky coordinate descriptor. Imcoo is set to NULL +except in cases where the sky coordinate descriptor for an image is +transformed and written back to the same image. +.ih +DESCRIPTION +Sk_decim is an integer function which returns OK or ERR as its function +value. ERR is returned if a valid sky coordinate system cannot be opened, +OK otherwise. + +Sk_decim returns the image MWCS descriptor mw. The MWCS descriptor is used +to convert from pixel coordinates to world coordinates and vice versa. +The MWCS descriptor must be freed with a call to the MWCS routine +mw_close before task termination. + +Sk_decim returns the sky descriptor coo. The sky coordinate descriptor +is defined even if an error is detected in reading the image celestial +coordinate system, and must be freed with a call to sk_close before +task termination. + +.ih +NOTES +Type "help ccsystems" to see the list of the supported sky coordinate systems. + +Type "help mwcs$MWCS.hlp fi+" to find out more about the IRAF image world +coordinate system library MWCS. +SEE ALSO +skdecwcs, skdecwstr, skcopy, skclose +.endhelp diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skdecwcs.hlp b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skdecwcs.hlp new file mode 100644 index 00000000..2081fd50 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skdecwcs.hlp @@ -0,0 +1,62 @@ +.help skdecwcs Mar00 Skywcs +.ih +NAME +skdecwcs -- open a sky coordinate descriptor using an image or system name +.ih +SYNOPSIS +stat = sk_decwcs (ccsystem, mw, coo, imcoo) + +.nf +char ccsystem # the input celestial coordinate system name +pointer mw # the output mwcs descriptor +pointer coo # the output sky coordinate descriptor +pointer imcoo # the input image sky coordinate descriptor +.fi +.ih +ARGUMENTS +.ls ccsystem. +The celestial coordinate system name. Ccsystem is a either an image system +name, e.g. "dev$ypix logical" or "dev$ypix world" or a system name, e.g. +"J2000" or "galactic". +.le +.ls mw +The output mwcs descriptor. A NULL value for mw is returned if the +image world coordinate system cannot be read or ccsystem is not an image +system name. +.le +.ls coo +The output sky coordinate descriptor. +.le +.ls imcoo +The parent image coordinate descriptor. Imcoo is set to NULL +except in cases where the sky coordinate descriptor for an image is +transformed and written back to the same image. +.le +.ih +DESCRIPTION +Sk_decwcs is an integer function which returns OK or ERR as its function +value. ERR is returned if a valid sky coordinate system cannot be opened, +OK otherwise. + +Sk_decwcs returns the image MWCS descriptor mw if ccsystem is an image +system, otherwise it returns NULL. The MWCS descriptor is used +to convert from pixel coordinates to world coordinates and vice versa. +The MWCS descriptor must be freed with a call to the MWCS routine +mw_close before task termination. + +Sk_decwcs returns the sky descriptor coo. The sky coordinate descriptor +is defined even if an error is detected in reading the image celestial +coordinate system, and must be freed with a call to sk_close before +task termination. + +.ih +NOTES +Type "help ccsystems" to see the list of the supported sky coordinate systems. + +Type "help mwcs$MWCS.hlp fi+" to find out more about the IRAF image world +coordinate system library MWCS. + + +SEE ALSO +skdecwstr, skdecim +.endhelp diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skdecwstr.hlp b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skdecwstr.hlp new file mode 100644 index 00000000..f81c2d48 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skdecwstr.hlp @@ -0,0 +1,46 @@ +.help skdecwstr Mar00 Skywcs +.ih +NAME +skdecwstr -- open a sky coordinate descriptor using a system name +.ih +SYNOPSIS +stat = sk_decwstr (csystem, coo, imcoo) + +.nf +char csystem # the input celestial coordinate system name +pointer coo # the output sky coordinate descriptor +pointer imcoo # the input image sky coordinate descriptor +.fi +.ih +ARGUMENTS +.ls csystem +The sky coordinates definition. Ccsystem is a system name, e.g. "J2000" +or "galactic. +.le +.ls coo +The output sky coordinate descriptor. +.le +.ls imcoo +The parent image coordinate descriptor. Imcoo is set to NULL +except in cases where the sky coordinate descriptor for an image is +transformed and written back to the same image. +.le +.ih +DESCRIPTION +Sk_decwstr is an integer function which returns OK or ERR as its function +value. ERR is returned if a valid sky coordinate system cannot be opened, +OK otherwise. + +Sk_decwstr returns the sky descriptor coo. The sky coordinate descriptor +is defined even if an error is detected in reading the image celestial +coordinate system, and must be freed with a call to sk_close before +task termination. + +.ih +NOTES + +Type "help ccsystems" to get a list of the supported sky coordinate systems. + +SEE ALSO +skdecwcs, skdecim, skcopy, skclose +.endhelp diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skenwcs.hlp b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skenwcs.hlp new file mode 100644 index 00000000..cc388108 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skenwcs.hlp @@ -0,0 +1,32 @@ +.help skenwcs Mar00 Skywcs +.ih +NAME +skenwcs -- encode a system name using a sky coordinate descriptor +.ih +SYNOPSIS + +call sk_enwcs (coo, csystem, maxch) + +.nf +pointer coo # the input sky coordinate descriptor +char csystem # the output system name +int maxch # the maximum size of the output system name +.fi +.ih +ARGUMENTS +.ls coo +The input sky coordinate descriptor +.le +.ls csystem +The output system name, e.g. "galactic". +.le +.ls maxch +The maximum size of the output system name. +.le +.ih +DESCRIPTION +Sk_enwcs returns the sky coordinate system name. +.ih +SEE ALSO +skdecwcs, skdecwstr +.endhelp diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skequatorial.hlp b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skequatorial.hlp new file mode 100644 index 00000000..4adc7590 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skequatorial.hlp @@ -0,0 +1,59 @@ +.help skequatorial Mar00 Skywcs +.ih +NAME +skequatorial -- apply pm and transform between equatorial coordinate systems +.ih +SYNOPSIS +call sk_equatorial (incoo, outcoo, ilng, ilat, ipmlng, ipmlat, px, rv, + olng, olat) + +.nf +pointer incoo # the input sky coordinate descriptor +pointer outcoo # the output sky coordinate descriptor +double ilng, ilat # the input sky coordinates in radians +double ipmlng, ipmlat # the input proper motions in radians / year +double px # the input parallax in arcsec +double rv # the input radial velocity in km / sec (+ve receding) +double olng, olat # the output output sky coordinates in radians +.fi +.ih +ARGUMENTS +.ls incoo +The input sky coordinate descriptor. +.le +.ls parameter +.ls outcoo +The output sky coordinate descriptor. +.le +.ls ilng, ilat +The input sky coordinates in radians. +.le +.ls ipmlng, ipmlat +The input proper motions. If proper motions are unknown do not set ipmlng +and ipmlat to 0.0, use sk_ultran instead. Note that the ra proper motion +is in dra not cos (dec) * dra units. +.le +.ls px +The parallax in arcseconds. Use 0.0 if the proper motion is unknown unknown. +The parallax value is used only if proper motions are defined. +.le +.ls rv +The radial velocity in km / sec. Use 0.0 if the radial velocity is unknown. +The radial velocity value is used only if proper motions are defined. +.le +.ls olng, olat +The output sky coordinates in radians. +.le +.ih +DESCRIPTION +The coordinates in the input sky coordinate system are converted to +coordinates in the output sky coordinate system. +.ih +NOTES +If the proper motions are undefined use the routine sk_ultran. Zero valued +proper motions are not the same as undefined proper motions. + +.ih +SEE ALSO +sk_lltran, sk_ultran +.endhelp diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skiiprint.hlp b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skiiprint.hlp new file mode 100644 index 00000000..217819c2 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skiiprint.hlp @@ -0,0 +1,39 @@ +.help skiiprint Mar00 Skywcs +.ih +NAME +skiiprint -- print the sky coordinate system summary +.ih +SYNOPSIS + +call sk_iprint (label, imagesys, mw, coo) + +.nf +char label # the input user label +char imagesys # the input image system +pointer mw # the input mwcs descriptor +pointer coo # the sky coordinate descriptor +.fi +.ih +ARGUMENTS +.ls label +The input user supplied label, e.g. "Input System", "Ref System", +"Output System" etc. +.le +.ls imagesys +The input image system, e.g. "dev$ypix logical", "dev$ypix world", etc. +.le +.ls mwcs +The input image mwcs descriptor if defined. If mwcs is defined then +information about which sky coordinate corresponds to which image +axis etc is read from the mwcs descriptor. +.le +.ls coo +The input sky coordinate descriptor. +.le +.ih +DESCRIPTION +A summary of the sky coordinate system is printed on the standard output. +.ih +SEE ALSO +skiiwrite +.endhelp diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skiiwrite.hlp b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skiiwrite.hlp new file mode 100644 index 00000000..c82472f4 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skiiwrite.hlp @@ -0,0 +1,43 @@ +.help skiiwrite Mar00 Skywcs +.ih +NAME +skiiwrite -- write the sky coordinate system summary to a file +.ih +SYNOPSIS + +call sk_iiwrite (outfd, label, imagesys, mw, coo) + +.nf +int outfd # the input file descriptor +char label # the input user label +char imagesys # the input image system +pointer mw # the input mwcs descriptor +pointer coo # the sky coordinate descriptor +.fi +.ih +ARGUMENTS +.ls outfd +The input file descriptor. +.le +.ls label +The input user supplied label, e.g. "Input System", "Ref System", +"Output System" etc. +.le +.ls imagesys +The input image system, e.g. "dev$ypix logical", "dev$ypix world", etc. +.le +.ls mwcs +The input image mwcs descriptor if defined. If mwcs is defined then +information about which sky coordinate corresponds to which image +axis etc is read from the mwcs descriptor. +.le +.ls coo +The input sky coordinate descriptor. +.le +.ih +DESCRIPTION +A summary of the sky coordinate system is written to a file. +.ih +SEE ALSO +skiiprint +.endhelp diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/sklltran.hlp b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/sklltran.hlp new file mode 100644 index 00000000..a0040507 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/sklltran.hlp @@ -0,0 +1,60 @@ +.help sklltran Mar00 Skywcs +.ih +NAME +sklltran -- apply pm and transform between coordinate systems +.ih +SYNOPSIS +call sk_lltran (incoo, outcoo, ilng, ilat, ipmlng, ipmlat, px, rv, olng, olat) + +.nf +pointer incoo # the input sky coordinate descriptor +pointer outcoo # the output sky coordinate descriptor +double ilng, ilat # the input sky coordinates in radians +double ipmlng, ipmlat # the input proper motions in radians / year +double px # the input parallax in arcsec +double rv # the input radial velocity in km / sec (+ve receding) +double olng, olat # the output sky coordinates in radians +.fi +.ih +ARGUMENTS +.ls incoo +The input sky coordinate descriptor. +.le +.ls parameter +.ls outcoo +The output sky coordinate descriptor. +.le +.ls ilng, ilat +The input sky coordinates in radians. +.le +.ls ipmlng, ipmlat +The input proper motions. For these to be applied the input coordinate +system must be an equatorial coordinate system. If proper motions are +unknown do not set ipmlng and ipmlat to 0.0, use sk_ultran instead. Note that +the ra proper motion is in dra not cos (dec) * dra units. +.le +.ls px +The parallax in arcseconds. Use 0.0 if the proper motion is unknown unknown. +The parallax value is used only if proper motions are defined. +.le +.ls rv +The radial velocity in km / sec. Use 0.0 if the radial velocity is unknown. +The radial velocity value is used only if proper motions are defined. +.le +.ls olng, olat +The onput sky coordinates in radians. +.le + +.ih +DESCRIPTION +The coordinates in the input sky coordinate system are converted to +coordinates in the output sky coordinate system. +.ih +NOTES +If the proper motions are undefined use the routine sk_ultran. Zero valued +proper motions are not the same as undefined proper motions. + +.ih +SEE ALSO +sk_ultran, sk_equatorial +.endhelp diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/sksaveim.hlp b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/sksaveim.hlp new file mode 100644 index 00000000..82c16f3f --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/sksaveim.hlp @@ -0,0 +1,39 @@ +.help sksaveim Mar00 Skywcs +.ih +NAME +sksaveim -- update the image header using a sky coordinate descriptor +.ih +SYNOPSIS +call sk_saveim (coo, mw, im) + +.nf +pointer coo # the input sky coordinate descriptor +pointer mw # the input mwcs descriptor +pointer im # the input image descriptor +.fi +.ih +ARGUMENTS +.ls coo +The input sky coordinate descriptor. +.le +.ls mw +The IRAF mwcs descriptor. +.le +.ls im +The input image descriptor. +.le +.ih +DESCRIPTION +The image world coordinate system is updated using information in +the sky coordinate descriptor and the mwcs descriptor. + +.ih +NOTES +Note that the sk_saveim call does not include a call to the MWCS mw_saveim +routine. This call must be made separately. + +Type "help mwcs$MWCS.hlp fi+" to find out more about the IRAF image world +coordinate system code. +SEE ALSO +skdecwcs, skdecim +.endhelp diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/sksetd.hlp b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/sksetd.hlp new file mode 100644 index 00000000..f518d71c --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/sksetd.hlp @@ -0,0 +1,53 @@ +.help sksetd Mar00 Skywcs +.ih +NAME +sksetd -- set a double sky coordinate descriptor parameter +.ih +SYNOPSIS +include <skywcs.h> + +call sk_setd (coo, parameter, dval) + +.nf +pointer coo # the input sky coordinate descriptor +int parameter # the double parameter to be set +double dval # the value of the parameter to be set +.fi +.ih +ARGUMENTS +.ls coo +The sky coordinate descriptor. +.le +.ls parameter +The parameter to be set. The double parameter definitions in skywcs.h are: +.nf + S_VXOFF # the logical ra / longitude offset in pixels + S_VYOFF # the logical dec / latitude offset in pixels + S_VXSTEP # the logical ra / longitude step size in pixels + S_VYSTEP # the logical dec / latitude step size in pixels + S_EQUINOX # the equinox in years + S_EPOCH # the MJD of the observation +.fi +.le +.ls dval +The value of the parameter to be set. +.le +.ih +DESCRIPTION +Sk_setd sets the values of double sky coordinate descriptor parameters. +.ih +NOTES +The offsets and step sizes default to 0 and 1 for both axes. However +if the sky coordinate descriptor was derived from an input image section, e.g. +"dev$ypix[100:300,100:300]" these numbers may assume other values in some +circumstances. + +The equinox and epoch of observation are normally set by the calling program +when the sky coordinate descriptor is initialized, e.g. they default +to 2000.0 and 51544.50000 if the input coordinate system was "fk5". + +In most cases these parameters should not be set by the user. +.ih +SEE ALSO +skseti, sksets +.endhelp diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skseti.hlp b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skseti.hlp new file mode 100644 index 00000000..b08be476 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skseti.hlp @@ -0,0 +1,93 @@ +.help skseti Mar00 Skywcs +.ih +NAME +skseti -- set an integer sky coordinate descriptor parameter +.ih +SYNOPSIS +include <skywcs.h> + +call sk_seti (coo, parameter, ival) + +.nf +pointer coo # the input sky coordinate descriptor +int parameter # the integer parameter to be set +int ival # the value of the parameter to be set +.fi +.ih +ARGUMENTS +.ls coo +The sky coordinate descriptor. +.le +.ls parameter +The parameter to be set. The double parameter definitions in skywcs.h are: +.nf + S_CTYPE # the celestial coordinate system type + S_RADECSYS # the equatorial system type + S_NLNGUNITS # the ra / longitude units + S_NLATUNITS # the dec/ latitude units + S_WTYPE # the projection type + S_PLNGAX # the physical ra / longitude axis + S_PLATAX # the physical dec / latitude axis + S_XLAX # the logical ra / longitude axis + S_YLAX # the logical dec / latitude axis + S_PIXTYPE # the IRAF pixel coordinate system type + S_NLNGAX # the length of ra / longitude axis + S_NLATAX # the length of dec / latitude axis + S_STATUS # the coordinate system status +.fi +.le +.ls ival +The value of the parameter to be set. +.le +.ih +DESCRIPTION +Sk_seti sets the values of integer sky coordinate descriptor parameters. +.ih +NOTES +Permitted values of S_CTYPE are CTYPE_EQUATORIAL, CTYPE_ECLIPTIC, +CTYPE_GALACTIC, and CTYPE_SUPERGALACTIC. The corresponding string dictionary +is CTYPE_LIST. + +Permitted types of S_RADECSYS are EQTYPE_FK4, EQTYPE_FK4NOE, +EQTYPE_FK5, EQTYPE, ICRS, and EQTYPE_GAPPT. The corresponding string +dictionary is EQTYPE_LIST. + +Permitted values of S_WTYPE are WTYPE_LIN, WTYPE_AZP, WTYPE_TAN, WTYPE_SIN, +WTYPE_STG, WTYPE_ARC, WTYPE_ZPN, WTYPE_ZEA, WTYPE_AIR, WTYPE_CYP, WTYPE_CAR, +WTYPE_MER, WTYPE_CEA, WTYPE_COP, WTYPE_COD, WTYPE_COE, WTYPE_COO, WTYPE_BON, +WTYPE_PCO, WTYPE_GLS, WTYPE_PAR, WTYPE_AIT, WTYPE_MOL, WTYPE_CSC, WTYPE_QSC, +WTYPE_TSC, WTYPE_TNX, WTYPE_ZPX. The corresponding string dictionary is +WTYPE_LIST. + +Permitted values of S_PIXTYPE are PIXTYPE_LOGICAL, PIXTYPE_TV, +PIXTYPE_PHYSICAL. and PIXTPE_WORLD. The corresponding string dictionary +is PIXTYPE_LIST. + +Permitted values of S_NLNGUNITS are SKY_HOURS, SKY_DEGREES, and SKY_RADIANS. +The corresponding string dictionary is SKY_LNG_UNITLIST. +Permitted values of S_NLATUNITS are SKY_DEGREES, and SKY_RADIANS. +The corresponding string dictionary is SKY_LAT_UNITLIST. + +The parameters S_CTYPE, S_RADECSYS, S_NLNGUNITS, and S_NLATUNITS are +important for all sky coordinate descriptors regardless of the source. +The parameters S_WTYPE, S_PLNGAX, S_PLATAX, S_XLAX, S_YLAX, S_PIXTYPE, +S_NLNGAX, and S_NLATAX are only important for sky coordinate descriptors +derived from an image sky coordinate systems. S_STATUS is OK if the sky +coordinate descriptor describes a valid celestial coordinate system, ERR +otherwise. + +In most cases these parameters should not be modified by the user. The +major exceptions are the units parameters S_NLNGUNITS and N_LATUNITS +which assumes default values fo hours and degrees for equatorial sky +coordinate systems and degrees and degrees for other sky coordinate systems. +If the user input and output units are different from the normal defaults +then the units parameters should be set appropriately. + +Parameters that occasionally need to be reset when a coordinate system +is created, edited, or saved to an image are S_WTYPE, S_PIXTYPE, S_PLNGAX, +and S_PLATAX. + +.ih +SEE ALSO +sksetd, sksets +.endhelp diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/sksets.hlp b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/sksets.hlp new file mode 100644 index 00000000..8e4179b4 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/sksets.hlp @@ -0,0 +1,36 @@ +.help sksets Mar00 Skywcs +.ih +NAME +sksets -- set a string sky coordinate descriptor parameter +.ih +SYNOPSIS +include <skywcs.h> + +call sk_sets (coo, parameter, str) + +.nf +pointer coo # the input sky coordinate descriptor +int parameter # the string parameter to be set +char str # the value of the string parameter to be set +.fi +.ih +ARGUMENTS +.ls coo +The sky coordinate descriptor. +.le +.ls parameter +The parameter to be set. The string parameter definitions in skywcs.h are: +.nf + S_COOSYSTEM # the celestial coordinate system name +.fi +.le +.ls str +The value of the parameter to be set. +.le +.ih +DESCRIPTION +Sk_sets sets the values of string sky coordinate descriptor parameters. +.ih +SEE ALSO +sksetd, skseti +.endhelp diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skstatd.hlp b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skstatd.hlp new file mode 100644 index 00000000..52dc0c70 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skstatd.hlp @@ -0,0 +1,49 @@ +.help skstatd Mar00 Skywcs +.ih +NAME +skstatd -- get a double sky coordinate descriptor parameter +.ih +SYNOPSIS +include <skywcs.h> + +dval = sk_statd (coo, parameter) + +.nf +pointer coo # the input sky coordinate descriptor +int parameter # the double parameter to be returned +.fi +.ih +ARGUMENTS +.ls coo +The sky coordinate descriptor. +.le +.ls parameter +The oarameter to be returned. The double parameter definitions in skywcs.h are: +.nf + S_VXOFF # the logical ra / longitude offset in pixels + S_VYOFF # the logical dec / latitude offset in pixels + S_VXSTEP # the logical ra / longitude step size in pixels + S_VYSTEP # the logical dec / latitude step size in pixels + S_EQUINOX # the equinox in years + S_EPOCH # the MJD of the observation +.fi +.le +.ih +DESCRIPTION +Sk_statd returns the values of double sky coordinate descriptor parameters. + +.ih +NOTES +The offsets and step sizes default to 0 and 1 for both axes. However +if the sky coordinate descriptor was derived from an input image section, e.g. +"dev$ypix[100:300,100:300]" these numbers may assume other values in some +circumstances. + +The equinox and epoch of observation are normally set by the calling program +when the sky coordinate descriptor is initialized, e.g. they default +to 2000.0 and 51544.50000 if the input coordinate system was "fk5". + +.ih +SEE ALSO +skstati, skstats +.endhelp diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skstati.hlp b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skstati.hlp new file mode 100644 index 00000000..90d33eb1 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skstati.hlp @@ -0,0 +1,79 @@ +.help skstati Mar00 Skywcs +.ih +NAME +skstati -- get an integer sky coordinate descriptor parameter +.ih +SYNOPSIS +include <skywcs.h> + +ival = sk_stati (coo, parameter) + +.nf +pointer coo # the input sky coordinate descriptor +int parameter # the integer parameter to be returned +.fi +.ih +ARGUMENTS +.ls coo +The sky coordinate descriptor. +.le +.ls parameter +Parameter to be returned. The integer parameter definitions in skywcs.h are: +.nf + S_CTYPE # the celestial coordinate system type + S_RADECSYS # the equatorial system type + S_NLNGUNITS # the ra / longitude units + S_NLATUNITS # the dec/ latitude units + S_WTYPE # the projection type + S_PLNGAX # the physical ra / longitude axis + S_PLATAX # the physical dec / latitude axis + S_XLAX # the logical ra / longitude axis + S_YLAX # the logical dec / latitude axis + S_PIXTYPE # the IRAF pixel coordinate system type + S_NLNGAX # the length of the ra / longitude axis + S_NLATAX # the length of the dec / latitude axis + S_STATUS # the coordinate system status +.fi +.le +.ih +DESCRIPTION +Sk_stati returns the values of integer sky coordinate descriptor parameters. + +.ih +NOTES +Permitted values of S_CTYPE are CTYPE_EQUATORIAL, CTYPE_ECLIPTIC, +CTYPE_GALACTIC, and CTYPE_SUPERGALACTIC. The corresponding string dictionary +is CTYPE_LIST. + +Permitted types of S_RADECSYS are EQTYPE_FK4, EQTYPE_FK4NOE, +EQTYPE_FK5, EQTYPE, ICRS, and EQTYPE_GAPPT. The corresponding string +dictionary is EQTYPE_LIST. + +Permitted values of S_WTYPE are WTYPE_LIN, WTYPE_AZP, WTYPE_TAN, WTYPE_SIN, +WTYPE_STG, WTYPE_ARC, WTYPE_ZPN, WTYPE_ZEA, WTYPE_AIR, WTYPE_CYP, WTYPE_CAR, +WTYPE_MER, WTYPE_CEA, WTYPE_COP, WTYPE_COD, WTYPE_COE, WTYPE_COO, WTYPE_BON, +WTYPE_PCO, WTYPE_GLS, WTYPE_PAR, WTYPE_AIT, WTYPE_MOL, WTYPE_CSC, WTYPE_QSC, +WTYPE_TSC, WTYPE_TNX, WTYPE_ZPX. The corresponding string dictionary is +WTYPE_LIST. + +Permitted values of S_PIXTYPE are PIXTYPE_LOGICAL, PIXTYPE_TV, +PIXTYPE_PHYSICAL. and PIXTPE_WORLD. The corresponding string dictionary +is PIXTYPE_LIST. + +Permitted values of S_NLNGUNITS are SKY_HOURS, SKY_DEGREES, and SKY_RADIANS. +The corresponding string dictionary is SKY_LNG_UNITLIST. +Permitted values of S_NLATUNITS are SKY_DEGREES, and SKY_RADIANS. +The corresponding string dictionary is SKY_LAT_UNITLIST. + +The parameters S_CTYPE, S_RADECSYS, S_NLNGUNITS, and S_NLATUNITS are +important for all sky coordinate descriptors regardless of the source. +The parameters S_WTYPE, S_PLNGAX, S_PLATAX, S_XLAX, S_YLAX, S_PIXTYPE, +S_NLNGAX, and S_NLATAX are only important for sky coordinate descriptors +derived from an image sky coordinate systems. S_STATUS is OK if the sky +coordinate descriptor describes a valid celestial coordinate system, ERR +otherwise. + +.ih +SEE ALSO +skstatd, skstats +.endhelp diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skstats.hlp b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skstats.hlp new file mode 100644 index 00000000..483ed3e5 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skstats.hlp @@ -0,0 +1,40 @@ +.help skstats Mar00 Skywcs +.ih +NAME +skstats -- get a string sky coordinate descriptor parameter +.ih +SYNOPSIS +include <skywcs.h> + +call sk_stats (coo, parameter, str, maxch) + +.nf +pointer coo # the input sky coordinate descriptor +int parameter # the string parameter to be returned +char str # the returned string parameter value +int maxch # the maximum size of the returned string parameter +.fi +.ih +ARGUMENTS +.ls coo +The sky coordinate descriptor. +.le +.ls parameter +The parameter to be returned. The string parameter definitions in skywcs.h are: +.nf + S_COOSYSTEM # the celestial coordinate system name +.fi +.le +.ls str +The value of the returned string. +.le +.ls maxch +The maximum size of the returned string. +.le +.ih +DESCRIPTION +Sk_stats returns the values of string sky coordinate descriptor parameters. +.ih +SEE ALSO +skstati, skstatd +.endhelp diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skultran.hlp b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skultran.hlp new file mode 100644 index 00000000..417eaba6 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skultran.hlp @@ -0,0 +1,51 @@ +.help skultran Mar00 Skywcs +.ih +NAME +skultran -- transform between coordinate systems +.ih +SYNOPSIS +call sk_ultran (incoo, outcoo, ilng, ilat, olng, olat, npts) + +.nf +pointer incoo # the input sky coordinate descriptor +pointer outcoo # the output sky coordinate descriptor +double ilng, ilat # the input celestial coordinates in expected units +double olng, olat # the output celestial coordinates in expected units +int npts # the number of input and output coordinate pairs +.fi +.ih +ARGUMENTS +.ls incoo +The input sky coordinate descriptor. +.le +.ls parameter +.ls outcoo +The output sky coordinate descriptor. +.le +.ls ilng, ilat +The input sky coordinates in the units defined by the integer parameters +S_NLNGUNITS and S_NLATUNITS. +.le +.ls olng, olat +The output sky coordinates in the units defined by the integer parameters +S_NLNGUNITS and S_NLATUNITS. +.le +.ls npts +The number of input and output coordinate pairs. +.le +.ih +DESCRIPTION +The coordinates in the input coordinate system are converted to +coordinates in the output coordinates system. + +If the calling program has not set the S_NLNGUNITS and S_NLATUNITS parameters +in either system the expected coordinates are hours and degrees for +equatorial sky coordinate systems and degrees and degrees for other sky +coordinate systems. The calling program must either perform the necessary +coordinate conversions or set the units parameters in the input and output +sky coordinate descriptors appropriately. + +.ih +SEE ALSO +sk_lltran, sk_equatorial +.endhelp diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skywcs.hd b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skywcs.hd new file mode 100644 index 00000000..74bac140 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skywcs.hd @@ -0,0 +1,25 @@ +# Help directory for the SKYWCS library + +$doc = "./" +$source = "../" + +skdecwcs hlp=doc$skdecwcs.hlp, src=source$skdecode.x +skdecwstr hlp=doc$skdecwstr.hlp, src=source$skdecode.x +skdecim hlp=doc$skdecim.hlp, src=source$skdecode.x +skenwcs hlp=doc$skenwcs.hlp, src=source$skdecode.x +skcopy hlp=doc$skcopy.hlp, src=source$skdecode.x +skiiprint hlp=doc$skiiprint.hlp, src=source$skwrite.x +skiiwrite hlp=doc$skiiwrite.hlp, src=source$skwrite.x +skstati hlp=doc$skstati.hlp, src=source$skstat.x +skstatd hlp=doc$skstatd.hlp, src=source$skstat.x +skstats hlp=doc$skstats.hlp, src=source$skstat.x +skseti hlp=doc$skseti.hlp, src=source$skset.x +sksetd hlp=doc$sksetd.hlp, src=source$skset.x +sksets hlp=doc$sksets.hlp, src=source$skset.x +skultran hlp=doc$skultran.hlp, src=source$skytransform.x +sklltran hlp=doc$sklltran.hlp, src=source$skytransform.x +skequatorial hlp=doc$skequatorial.hlp, src=source$skytransform.x +sksaveim hlp=doc$sksaveim.hlp, src=source$sksaveim.x +skclose hlp=doc$skclose.hlp, src=source$skdecode.x + +ccsystems hlp=doc$ccsystems.hlp diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skywcs.hlp b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skywcs.hlp new file mode 100644 index 00000000..498f9b43 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skywcs.hlp @@ -0,0 +1,306 @@ +.help skywcs Oct00 xtools +.ih +NAME +skywcs -- sky coordinates package +.ih +SYNOPSIS + +.nf + stat = sk_decwcs (ccsystem, mw, coo, imcoo) + stat = sk_decwstr (ccsystem, coo, imcoo) + stat = sk_decim (im, wcs, mw, coo) + sk_enwcs (coo, ccsystem, maxch) + newcoo = sk_copy (coo) + sk_iiprint (label, imagesys, mw, coo) + sk_iiwrite (fd, label, imagesys, mw, coo) +[id]val = sk_stat[id] (coo, param) + sk_stats (coo, param, str, maxch) + sk_set[id] (coo, param, [id]val) + sk_sets (coo, param, str) + sk_ultran (incoo, outcoo, ilng, ilat, olng, olat, npts) + sk_lltran (incoo, outoo, ilng, ilat, ipmlng, ipmlat, px, rv, + olng, olat) + sk_equatorial (incoo, outcoo, ilng, ilat, ipmlng, ipmlat, px, + rv, olng, olat) + sk_saveim (coo, mw, im) + sk_close (coo) + +.fi +.ih +DESCRIPTION + +The skywcs package contains a simple set of routines for doing managing +sky coordinate information and for transforming from one sky coordinate +system to another. The sky coordinate system is defined either by a system +name, e.g. "J2000", "galactic, etc. or by an image system name, e.g. +"dev$ypix" or "dev$ypix world". + +The skywcs routine are layered on the Starlink Positional Astronomy library +SLALIB which is installed in the IRAF MATH package. Type "help slalib +option=sys" for more information about SLALIB. + + +.ih +NOTES + +An "include <skywcs.h>" statement must be included in the calling program +to make the skywcs package parameter definitions visible to the calling +program. + +The sky coordinate descriptor is created with a call to one of the sk_decwcs +sk_decwstr or sk_imwcs routines. If the source of sky coordinate descriptor +is an image then an IRAF MWCS descriptor will be returned with the sky +oordinate descriptor. The sky coordinate descriptor is freed with a +call to sk_close. A separate call to mw_close must be made to free the +MWCS descriptor if one was allocated. + +By default the main skywcs coordinate transformation routine sk_ultran +assumes that the input and output sky coordinates are in hours and degrees +if the input and output coordinate systems are equatorial, otherwise the +coordinates are assumed to be in degrees and degrees. The default input and +output sky coordinate units can be reset with calls to sk_seti. Two lower level +coordinate transformations for handling proper motions sk_lltran and +sk_equatorial are also available. These routines that the input and output +coordinates and proper motions are in radians. + +Calling programs working with both sky coordinate and MWCS descriptors +need to be aware that the MWCS routines assume that all sky coordinates +must be input in degrees and will be output in degrees and adjust their +code accordingly. + +The skywcs routine sk_saveim can be used to update an image header. + + +.ih +EXAMPLES +.nf +Example 1: Convert from B1950 coordinates to J2000 coordinates. + + include <skywcs.h> + + .... + + # Open input coordinate system. + instat = sk_decwstr ("B1950", incoo, NULL) + if (instat == ERR) { + call sk_close (incoo) + return + } + + # Open output coordinate system. + outstat = sk_decwstr ("J2000", outcoo, NULL) + if (outstat == ERR) { + call sk_close (outcoo) + return + } + + # Do the transformation assuming the input coordinates are in hours + # and degrees. The output coordinates will be in hours and degrees + # as well. + call sk_ultran (incoo, outcoo, rain, decin, raout, decout, npts) + + # Close the coordinate descriptors. + call sk_close (incoo) + call sk_close (outcoo) + + ... + + +Example 2: Repeat example 1 but convert to galactic coordinates. + + include <skywcs.h> + + .... + + # Open the input coordinate system. + instat = sk_decwstr ("B1950", incoo, NULL) + if (instat == ERR) { + call sk_close (incoo) + return + } + + # Open the output coordinate system. + outstat = sk_decwstr ("galactic", outcoo, NULL) + if (outstat == ERR) { + call sk_close (outcoo) + return + } + + # Dd the transformation assuming the input coordinates are in hours and + # degrees. The output coordinates will be in degrees and degrees. + call sk_ultran (incoo, outcoo, rain, decin, raout, decout, npts) + + # Close the coordinate descriptors. + call sk_close (incoo) + call sk_close (outcoo) + + ... + +Example 3: Convert a grid of pixel coordinates in the input image to the + equivalent pixel coordinate in the output image using the + image world coordinate systems to connect the two. + + include <skywcs.h> + + .... + + # Mwref will be defined because the input system is an image. + refstat = sk_decwcs ("refimage logical", mwref, refcoo, NULL) + if (refstat == ERR || mwref == NULL) { + if (mwref != NULL) + call mw_close (mwref) + call sk_close (refcoo) + return + } + + # Set the reference coordinate descriptor so it expects input in degrees + # and degrees. + call sk_seti (refcoo, S_NLNGUNUTS, SKY_DEGREES) + call sk_seti (refcoo, S_NLATUNUTS, SKY_DEGREES) + + # Mwout will be defined because the output system is an image. + outstat = sk_decwcs ("image logical", mwout, outcoo, NULL) + if (outstat == ERR || mwout == NULL) { + if (mwout != NULL) + call mw_close (mwout) + call sk_close (outcoo) + call mw_close (mwref) + call sk_close (refcoo) + return + } + + # Set the output coordinate descriptor so it will output coordinates + # in degrees and degrees. + call sk_seti (outcoo, S_NLNGUNUTS, SKY_DEGREES) + call sk_seti (outcoo, S_NLATUNUTS, SKY_DEGREES) + + # Compute pixel grid in refimage and store coordinate in the arrays + # xref and yref. + npts = 0 + do j = 1, IM_LEN(im,2), 100 { + do i = 1, IM_LEN(im,1), 100 { + npts = npts + 1 + xref[npts] = i + yref[npts] = j + } + } + + # Convert xref and yref to celestial coordinates raref and decref using + # mwref. The output coordinates will be in degrees and degrees. + ctref = mw_sctran (mwref, "logical", "world", 03B) + do i = 1, npts + call mw_c2trand (ctref, xref[i], yref[i], raref[i], decref[i]) + call ct_free (ctref) + + # Convert the reference celestial coordinates to the output celestial + # coordinate system using the coordinate descriptors. + call sk_ultran (refcoo, outcoo, raref, decref, raout, decout, npts) + + # Convert the output celestial coordinates to pixel coordinates in + # the other image using mwout. + ctout = mw_sctran (mwout, "world", "logical", 03B) + do i = 1, npts + call mw_c2trand (ctout, raout[i], decout[i], xout[i], yout[i]) + call ct_free (ctout) + + # Print the input and output pixel coordinates. + do i = 1, npts { + call printf ("%10.3f %10.3f %10.3f %10.3f\n") + call pargd (xref[i]) + call pargd (yref[i]) + call pargd (xout[i]) + call pargd (yout[i]) + } + + # Tidy up. + call mw_close (mwref) + call mw_close (mwout) + call sk_close (refcoo) + call sk_close (outcoo) + + +Example 4: Convert a 2D image with an J2000 tangent plane projection + wcs to the equivalent galactic wcs. The transformation + requires a shift in origin and a rotation. Assume that the ra + axis is 1 and the dec axis is 2. The details of how to compute + the rotation are not shown here. See the + imcctran task for details. + + include <mwset.h> + include <skywcs.h> + + ... + + # Open image. + im = immap (image, READ_WRITE, 0) + + # Open the image coordinate system. + instat = sk_decim (im, "logical", mwin, cooin) + if (instat == ERR || mwin == NULL) { + ... + call sk_close (cooin) + ... + } + + # Get the dimensions of the mwcs descriptor. This should be 2. + ndim = mw_ndim (mwin, MW_NPHYSDIM) + + # Get the default coordinates to degrees and degreees. + call sk_seti (cooin, S_NLNGUNITS, SKY_DEGREES) + call sk_seti (cooin, S_NATGUNITS, SKY_DEGREES) + + # Open the output coordinate system. Mwout is NULL because this system + # is not an image. + outstat = sk_decwstr ("galactic", mwout, cooout, cooin) + if (outstat == ERR) { + ... + call sk_close (outstat) + ... + } + + # Make a copy of the mwcs descriptor. + mwout = mw_newcopy (mwin) + + # Allocate space for the r and w vectors and cd matrix. + call malloc (r, ndim, TY_DOUBLE) + call malloc (w, ndim, TY_DOUBLE) + call malloc (cd, ndim * ndim, TY_DOUBLE) + call malloc (newcd, ndim * ndim, TY_DOUBLE) + + # Assume for simplicty that the MWCS LTERM is the identify transform. + # so we don't have to worry about it. Get the WTERM which consists + # of r the reference point in pixels, w the reference point in degrees, + # and the cd matrix in degrees per pixel. + call mw_gwtermd (mwin, Memd[r], Memd[w], Memd[cd], ndim) + + # Convert the world coordinates zero point. The pixel zero point + # remains the same. + tilng = Memd[w] + tilat = Memd[w+1] + call sk_ultran (incoo, outcoo, tilng, tilat, tolng, tolat, 1) + Memd[w] = tolng + Memd[w+1] = tolat + + # Figure out how much to rotate the coordinate system and edit the + # compute a new CD matrix. Call it newcd. + ... + + # Enter the new CD matrix and zero point. + call mw_swterm (mwout, Memd[r], Memd[w], Memd[newcd], ndim) + + # Update the header. + call sk_saveim (cooout, mwout, im) + call mw_saveim (mwout, im) + ... + + # Tidy up. + call mfree (r, TY_DOUBLE) + call mfree (w, TY_DOUBLE) + call mfree (cd, TY_DOUBLE) + call mfree (newcd, TY_DOUBLE) + call mw_close (mwin) + call mw_close (mwout) + call sk_close (cooin) + call sk_close (cooout) + call imunmap (im) +.fi diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skywcs.men b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skywcs.men new file mode 100644 index 00000000..9eecc277 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/doc/skywcs.men @@ -0,0 +1,15 @@ + skdecwcs - Open a sky coordinate descriptor usning an image or system name + skdecwstr - Open a sky coordinate descriptor using a system name + skdecim - Open a sky coordinate descriptor using an image descriptor + skenwcs - Encode a system name using a sky coordinate descriptor + skcopy - Copy a sky coordinate descriptor + skstat[ids] - Get a sky coordinate descriptor parameter value + skset[ids] - Set a sky coordinate descriptor parameter value + skiiprint - Print a sky coordinate descriptor summary + skiiwrite - Write a sky coordinate descriptor summary + skultran - Transform between coordinate systems + sklltran - Apply pm and transform between coordinates systems +skequatorial - Apply pm and transform between equatorial coordinate systems + sksaveim - Update image header using sky coordinate descriptor + skclose - Close the sky coordinate descriptor + ccsystems - Describe the supported celestial coordinate systems diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/mkpkg b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/mkpkg new file mode 100644 index 00000000..ad049271 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/mkpkg @@ -0,0 +1,16 @@ +# Libary for the celestial coordinate sytem pacakge + +$checkout libpkg.a ../../ +$update libpkg.a +$checkin libpkg.a ../../ +$exit + +libpkg.a: + skdecode.x <imio.h> <imhdr.h> <mwset.h> skywcsdef.h skywcs.h + skwrite.x skywcsdef.h skywcs.h + skstat.x skywcsdef.h skywcs.h + skset.x skywcsdef.h skywcs.h + sktransform.x <math.h> skywcsdef.h skywcs.h + sksaveim.x skywcsdef.h skywcs.h + skwrdstr.x + ; diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skdecode.f b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skdecode.f new file mode 100644 index 00000000..03e49f1b --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skdecode.f @@ -0,0 +1,1412 @@ + integer function skdecs (instr, mw, coo, imcoo) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer mw + integer coo + integer imcoo + integer*2 instr(*) + integer stat + integer sp + integer str1 + integer str2 + integer laxno + integer paxval + integer im + integer skstrs + integer skdecm + integer immap + logical xerpop + logical xerflg + common /xercom/ xerflg + integer sw0001 + save + call xcallc(coo, (30 + 255 + 1), 10 ) + call xstrcy(instr, memc((((coo+25)-1)*2+1)) , 255 ) + call smark (sp) + call salloc (str1, 1023 , 2) + call salloc (str2, 1023 , 2) + call salloc (laxno, 7 , 4) + call salloc (paxval, 7 , 4) + call sscan (instr) + call gargwd (memc(str1), 1023 ) + call gargwd (memc(str2), 1023 ) + call xerpsh + im = immap (memc(str1), 1 , 0) + if (xerflg) goto 112 +112 if (.not.xerpop()) goto 110 + mw = 0 + if (.not.(imcoo .eq. 0)) goto 120 + memi(coo+20) = 2048 + memi(coo+21) = 2048 + memi(coo+15) = 1 + memi(coo+16) = 2 + memi(coo+17) = 1 + memi(coo+18) = 2 + memd((((coo)-1)/2+1)) = 0.0d0 + memd((((coo+2)-1)/2+1)) = 0.0d0 + memd((((coo+4)-1)/2+1)) = 1.0d0 + memd((((coo+6)-1)/2+1)) = 1.0d0 + memi(coo+14) = 0 + goto 121 +120 continue + memi(coo+20) = memi(imcoo+20) + memi(coo+21) = memi(imcoo+21) + memi(coo+15) = memi(imcoo+15) + memi(coo+16) = memi(imcoo+16) + memi(coo+17) = memi(imcoo+17) + memi(coo+18) = memi(imcoo+18) + memd((((coo)-1)/2+1)) = memd((((imcoo)-1)/2+1)) + memd((((coo+2)-1)/2+1)) = memd((((imcoo+2)-1)/2+1)) + memd((((coo+4)-1)/2+1)) = memd((((imcoo+4)-1)/2+1)) + memd((((coo+6)-1)/2+1)) = memd((((imcoo+6)-1)/2+1)) + memi(coo+14) = memi(imcoo+14) +121 continue + memi(coo+19) = 4 + stat = skstrs (instr, memi(coo+12) , memi(coo+13) , memd(((( + * coo+8)-1)/2+1)) , memd((((coo+10)-1)/2+1)) ) + sw0001=(memi(coo+12) ) + goto 130 +140 continue + memi(coo+22) = 3 + memi(coo+23) = 1 + goto 131 +150 continue + memi(coo+22) = 1 + memi(coo+23) = 1 + goto 131 +130 continue + if (sw0001.eq.1) goto 140 + goto 150 +131 continue + goto 111 +110 continue + stat = skdecm (im, memc(str2), mw, coo) + call imunmp (im) +111 continue + call sfree (sp) + memi(coo+24) = stat + skdecs = (stat) + goto 100 +100 return + end + integer function skdecr (instr, coo, imcoo) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer coo + integer imcoo + integer*2 instr(*) + integer stat + integer skstrs + integer sw0001 + save + call xcallc(coo, (30 + 255 + 1), 10 ) + call xstrcy(instr, memc((((coo+25)-1)*2+1)) , 255 ) + if (.not.(imcoo .eq. 0)) goto 110 + memi(coo+20) = 2048 + memi(coo+21) = 2048 + memi(coo+15) = 1 + memi(coo+16) = 2 + memi(coo+17) = 1 + memi(coo+18) = 2 + memd((((coo)-1)/2+1)) = 0.0d0 + memd((((coo+2)-1)/2+1)) = 0.0d0 + memd((((coo+4)-1)/2+1)) = 1.0d0 + memd((((coo+6)-1)/2+1)) = 1.0d0 + memi(coo+14) = 0 + goto 111 +110 continue + memi(coo+20) = memi(imcoo+20) + memi(coo+21) = memi(imcoo+21) + memi(coo+15) = memi(imcoo+15) + memi(coo+16) = memi(imcoo+16) + memi(coo+17) = memi(imcoo+17) + memi(coo+18) = memi(imcoo+18) + memd((((coo)-1)/2+1)) = memd((((imcoo)-1)/2+1)) + memd((((coo+2)-1)/2+1)) = memd((((imcoo+2)-1)/2+1)) + memd((((coo+4)-1)/2+1)) = memd((((imcoo+4)-1)/2+1)) + memd((((coo+6)-1)/2+1)) = memd((((imcoo+6)-1)/2+1)) + memi(coo+14) = memi(imcoo+14) +111 continue + memi(coo+19) = 4 + stat = skstrs (instr, memi(coo+12) , memi(coo+13) , memd((((coo + * +8)-1)/2+1)) , memd((((coo+10)-1)/2+1)) ) + sw0001=(memi(coo+12) ) + goto 120 +130 continue + memi(coo+22) = 3 + memi(coo+23) = 1 + goto 121 +140 continue + memi(coo+22) = 1 + memi(coo+23) = 1 + goto 121 +120 continue + if (sw0001.eq.1) goto 130 + goto 140 +121 continue + memi(coo+24) = stat + skdecr = (stat) + goto 100 +100 return + end + integer function skdecm (im, wcs, mw, coo) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer im + integer mw + integer coo + integer*2 wcs(*) + integer stat + integer sp + integer str1 + integer laxno + integer paxval + integer skimws + integer strdic + integer mwstai + integer mwopem + logical xerpop + logical xerflg + common /xercom/ xerflg + integer sw0001 + integer*2 st0001(6) + integer*2 st0002(28) + save + integer iyy + data st0001 / 37,115, 32, 37,115, 0/ + data (st0002(iyy),iyy= 1, 8) /124,108,111,103,105, 99, 97,108/ + data (st0002(iyy),iyy= 9,16) /124,116,118,124,112,104,121,115/ + data (st0002(iyy),iyy=17,24) /105, 99, 97,108,124,119,111,114/ + data (st0002(iyy),iyy=25,28) /108,100,124, 0/ + call xmallc(coo, (30 + 255 + 1), 10 ) + call sprinf (memc((((coo+25)-1)*2+1)) , 255 , st0001) + call pargsr (memc((((im+200 +165)-1)*2+1)) ) + call pargsr (wcs) + call smark (sp) + call salloc (str1, 1023 , 2) + call salloc (laxno, 7 , 4) + call salloc (paxval, 7 , 4) + call xerpsh + mw = mwopem (im) + if (xerflg) goto 112 +112 if (.not.xerpop()) goto 110 + memi(coo+12) = 0 + memi(coo+13) = 0 + memd((((coo+8)-1)/2+1)) = 1.6d308 + memd((((coo+10)-1)/2+1)) = 1.6d308 + mw = 0 + memi(coo+15) = 1 + memi(coo+16) = 2 + memi(coo+17) = 1 + memi(coo+18) = 2 + memi(coo+20) = 2048 + memi(coo+21) = 2048 + memd((((coo)-1)/2+1)) = 0.0d0 + memd((((coo+2)-1)/2+1)) = 0.0d0 + memd((((coo+4)-1)/2+1)) = 1.0d0 + memd((((coo+6)-1)/2+1)) = 1.0d0 + memi(coo+14) = 0 + memi(coo+19) = 1 + memi(coo+22) = 1 + memi(coo+23) = 1 + stat = -1 + goto 111 +110 continue + memi(coo+19) = strdic (wcs, memc(str1), 1023 , st0002) + if (.not.(memi(coo+19) .le. 0)) goto 120 + memi(coo+19) = 1 +120 continue + if (.not.(skimws (im, mw, memi(coo+12) , memi(coo+15) , memi + * (coo+16) , memi(coo+14) , memi(coo+13) , memd((((coo+8)-1)/2 + * +1)) , memd((((coo+10)-1)/2+1)) ) .eq. 0)) goto 130 + sw0001=(memi(coo+12) ) + goto 140 +150 continue + memi(coo+22) = 3 + memi(coo+23) = 1 + goto 141 +160 continue + memi(coo+22) = 1 + memi(coo+23) = 1 + goto 141 +140 continue + if (sw0001.eq.1) goto 150 + goto 160 +141 continue + call mwgaxp (mw, memi(laxno), memi(paxval), mwstai(mw, 5 + * )) + if (.not.(memi(laxno+memi(coo+15) -1) .lt. memi(laxno+ + * memi(coo+16) -1))) goto 170 + memi(coo+17) = memi(laxno+memi(coo+15) -1) + memi(coo+18) = memi(laxno+memi(coo+16) -1) + goto 171 +170 continue + memi(coo+17) = memi(laxno+memi(coo+16) -1) + memi(coo+18) = memi(laxno+memi(coo+15) -1) +171 continue + if (.not.(memi(coo+17) .le. 0 .or. memi(coo+18) .le. 0)) + * goto 180 + memd((((coo)-1)/2+1)) = 0.0d0 + memd((((coo+2)-1)/2+1)) = 0.0d0 + memd((((coo+4)-1)/2+1)) = 1.0d0 + memd((((coo+6)-1)/2+1)) = 1.0d0 + memi(coo+20) = 2048 + memi(coo+21) = 2048 + stat = -1 + goto 181 +180 continue + memd((((coo)-1)/2+1)) = meml(im+memi(im+memi(coo+17) + + * 47-1) +54-1) + memd((((coo+2)-1)/2+1)) = meml(im+memi(im+memi(coo+18) + * +47-1) +54-1) + memd((((coo+4)-1)/2+1)) = memi(im+memi(coo+17) +59-1) + memd((((coo+6)-1)/2+1)) = memi(im+memi(coo+18) +59-1) + memi(coo+20) = meml(im+200 +memi(coo+17) +8-1) + memi(coo+21) = meml(im+200 +memi(coo+18) +8-1) + stat = 0 +181 continue + goto 131 +130 continue + call mwcloe (mw) + mw = 0 + memi(coo+17) = 1 + memi(coo+18) = 2 + memi(coo+20) = 2048 + memi(coo+21) = 2048 + memd((((coo)-1)/2+1)) = 0.0d0 + memd((((coo+2)-1)/2+1)) = 0.0d0 + memd((((coo+4)-1)/2+1)) = 1.0d0 + memd((((coo+6)-1)/2+1)) = 1.0d0 + memi(coo+22) = 1 + memi(coo+23) = 1 + stat = -1 +131 continue +111 continue + call sfree (sp) + memi(coo+24) = stat + skdecm = (stat) + goto 100 +100 return + end + integer function skstrs (instr, ctype, radecs, equinx, epoch) + integer ctype + integer radecs + double precision equinx + double precision epoch + integer*2 instr(*) + integer ip + integer nitems + integer sctype + integer srades + integer stat + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer sp + integer str1 + integer str2 + integer strdic + integer nscan + integer ctod + double precision slej2d + double precision slepb + double precision sleb2d + double precision slepj + integer sw0001,sw0002,sw0003 + integer*2 st0001(63) + save + integer iyy + data (st0001(iyy),iyy= 1, 8) /124,102,107, 52,124,110,111,101/ + data (st0001(iyy),iyy= 9,16) /102,107, 52,124,102,107, 53,124/ + data (st0001(iyy),iyy=17,24) /105, 99,114,115,124, 97,112,112/ + data (st0001(iyy),iyy=25,32) / 97,114,101,110,116,124,101, 99/ + data (st0001(iyy),iyy=33,40) /108,105,112,116,105, 99,124,103/ + data (st0001(iyy),iyy=41,48) / 97,108, 97, 99,116,105, 99,124/ + data (st0001(iyy),iyy=49,56) /115,117,112,101,114,103, 97,108/ + data (st0001(iyy),iyy=57,63) / 97, 99,116,105, 99,124, 0/ + ctype = 0 + radecs = 0 + equinx = 1.6d308 + epoch = 1.6d308 + call smark (sp) + call salloc (str1, 1023 , 2) + call salloc (str2, 1023 , 2) + call sscan (instr) + call gargwd (memc(str1), 1023 ) + if (.not.(memc(str1) .eq. 0 .or. nscan() .lt. 1)) goto 110 + call sfree (sp) + skstrs = (-1) + goto 100 +110 continue + nitems = 1 +111 continue + sctype = strdic (memc(str1), memc(str2), 1023 , st0001) + if (.not.(sctype .le. 0)) goto 120 + ctype = 1 + goto 121 +120 continue + sw0001=(sctype) + goto 130 +140 continue + ctype = 1 + radecs = 1 + goto 131 +150 continue + ctype = 1 + radecs = 2 + goto 131 +160 continue + ctype = 1 + radecs = 3 + goto 131 +170 continue + ctype = 1 + radecs = 4 + goto 131 +180 continue + ctype = 1 + radecs = 5 + goto 131 +190 continue + ctype = 2 + goto 131 +200 continue + ctype = 3 + goto 131 +210 continue + ctype = 4 + goto 131 +130 continue + if (sw0001.lt.1.or.sw0001.gt.8) goto 131 + goto (140,150,160,170,180,190,200,210),sw0001 +131 continue + call gargwd (memc(str1), 1023 ) + if (.not.(nscan() .gt. nitems)) goto 220 + nitems = nitems + 1 +220 continue +121 continue + sctype = ctype + srades = radecs + sw0002=(sctype) + goto 230 +240 continue + sw0003=(srades) + goto 250 +260 continue + if (.not.(memc(str1) .eq. 74 .or. memc(str1) .eq. 106 .or + * . memc(str1) .eq. 66 .or. memc(str1) .eq. 98)) goto 270 + ip = 2 + goto 271 +270 continue + ip = 1 +271 continue + if (.not.(ctod (memc(str1), ip, equinx) .le. 0)) goto 280 + equinx = 1950.0d0 +280 continue + if (.not.(memc(str1) .eq. 74 .or. memc(str1) .eq. 106)) + * goto 290 + equinx = slepb (slej2d (equinx)) +290 continue + call gargwd (memc(str2), 1023 ) + if (.not.(nscan() .le. nitems)) goto 300 + epoch = sleb2d (equinx) + goto 301 +300 continue + if (.not.(memc(str2) .eq. 74 .or. memc(str2) .eq. 106 + * .or. memc(str2) .eq. 66 .or. memc(str2) .eq. 98)) goto + * 310 + ip = 2 + goto 311 +310 continue + ip = 1 +311 continue + if (.not.(ctod (memc(str2), ip, epoch) .le. 0)) goto + * 320 + epoch = sleb2d (equinx) + goto 321 +320 continue + if (.not.(epoch .le. 3000.0d0 .and. (memc(str2) .eq. + * 74 .or. memc(str2) .eq. 106))) goto 330 + epoch = slej2d (epoch) + goto 331 +330 continue + if (.not.(epoch .gt. 3000.0d0)) goto 340 + epoch = epoch - 2400000.5d0 + goto 341 +340 continue + epoch = sleb2d (epoch) +341 continue +331 continue +321 continue +301 continue + goto 251 +350 continue + if (.not.(memc(str1) .eq. 74 .or. memc(str1) .eq. 106 .or + * . memc(str1) .eq. 66 .or. memc(str1) .eq. 98)) goto 360 + ip = 2 + goto 361 +360 continue + ip = 1 +361 continue + if (.not.(ctod (memc(str1), ip, equinx) .le. 0)) goto 370 + equinx = 2000.0d0 +370 continue + if (.not.(memc(str1) .eq. 66 .or. memc(str1) .eq. 98)) + * goto 380 + equinx = slepj(sleb2d (equinx)) +380 continue + call gargwd (memc(str2), 1023 ) + if (.not.(nscan() .le. nitems)) goto 390 + epoch = slej2d (equinx) + goto 391 +390 continue + if (.not.(memc(str2) .eq. 74 .or. memc(str2) .eq. 106 + * .or. memc(str2) .eq. 66 .or. memc(str2) .eq. 98)) goto + * 400 + ip = 2 + goto 401 +400 continue + ip = 1 +401 continue + if (.not.(ctod (memc(str2), ip, epoch) .le. 0)) goto + * 410 + epoch = slej2d (equinx) + goto 411 +410 continue + if (.not.(epoch .le. 3000.0d0 .and. (memc(str2) .eq. + * 66 .or. memc(str2) .eq. 98))) goto 420 + epoch = sleb2d (epoch) + goto 421 +420 continue + if (.not.(epoch .gt. 3000.0d0)) goto 430 + epoch = epoch - 2400000.5d0 + goto 431 +430 continue + epoch = slej2d (epoch) +431 continue +421 continue +411 continue +391 continue + goto 251 +440 continue + equinx = 2000.0d0 + if (.not.(memc(str1) .eq. 74 .or. memc(str1) .eq. 106 .or + * . memc(str1) .eq. 66 .or. memc(str1) .eq. 98)) goto 450 + ip = 2 + goto 451 +450 continue + ip = 1 +451 continue + if (.not.(ctod (memc(str1), ip, epoch) .le. 0)) goto 460 + epoch = 1.6d308 + goto 461 +460 continue + if (.not.(epoch .le. 3000.0d0)) goto 470 + if (.not.(memc(str1) .eq. 66 .or. memc(str1) .eq. 98)) + * goto 480 + epoch = sleb2d (epoch) + goto 481 +480 continue + if (.not.(memc(str1) .eq. 74 .or. memc(str1) .eq. 106) + * ) goto 490 + epoch = slej2d (epoch) + goto 491 +490 continue + if (.not.(epoch .lt. 1984.0d0)) goto 500 + epoch = sleb2d (epoch) + goto 501 +500 continue + epoch = slej2d (epoch) +501 continue +491 continue +481 continue + goto 471 +470 continue + epoch = epoch - 2400000.5d0 +471 continue +461 continue + goto 251 +510 continue + ip = 1 + if (.not.(memc(str1) .eq. 66 .or. memc(str1) .eq. 98)) + * goto 520 + radecs = 1 + ip = ip + 1 + if (.not.(ctod (memc(str1), ip, equinx) .le. 0)) goto + * 530 + equinx = 1950.0d0 +530 continue + call gargwd (memc(str2), 1023 ) + if (.not.(nscan() .le. nitems)) goto 540 + epoch = sleb2d (equinx) + goto 541 +540 continue + if (.not.(memc(str2) .eq. 74 .or. memc(str2) .eq. + * 106)) goto 550 + ip = 2 + goto 551 +550 continue + if (.not.(memc(str2) .eq. 66 .or. memc(str2) .eq. + * 98)) goto 560 + ip = 2 + goto 561 +560 continue + ip = 1 +561 continue +551 continue + if (.not.(ctod (memc(str2), ip, epoch) .le. 0)) + * goto 570 + epoch = sleb2d (equinx) + goto 571 +570 continue + if (.not.(epoch .le. 3000.0d0 .and. (memc(str2) .eq + * . 74 .or. memc(str2) .eq. 106))) goto 580 + epoch = slej2d (epoch) + goto 581 +580 continue + if (.not.(epoch .gt. 3000.0d0)) goto 590 + epoch = epoch - 2400000.5d0 + goto 591 +590 continue + epoch = sleb2d (epoch) +591 continue +581 continue +571 continue +541 continue + goto 521 +520 continue + if (.not.(memc(str1) .eq. 74 .or. memc(str1) .eq. 106)) + * goto 600 + radecs = 3 + ip = ip + 1 + if (.not.(ctod (memc(str1), ip, equinx) .le. 0)) goto + * 610 + equinx = 2000.0d0 +610 continue + call gargwd (memc(str2), 1023 ) + if (.not.(nscan() .le. nitems)) goto 620 + epoch = slej2d (equinx) + goto 621 +620 continue + if (.not.(memc(str2) .eq. 74 .or. memc(str2) .eq. + * 106 .or. memc(str2) .eq. 66 .or. memc(str2) .eq. 98 + * )) goto 630 + ip = 2 + goto 631 +630 continue + ip = 1 +631 continue + if (.not.(ctod (memc(str2), ip, epoch) .le. 0)) + * goto 640 + epoch = slej2d (equinx) + goto 641 +640 continue + if (.not.(epoch .le. 3000.0d0 .and. (memc(str2) .eq + * . 66 .or. memc(str2) .eq. 98))) goto 650 + epoch = sleb2d (epoch) + goto 651 +650 continue + if (.not.(epoch .gt. 3000.0d0)) goto 660 + epoch = epoch - 2400000.5d0 + goto 661 +660 continue + epoch = slej2d (epoch) +661 continue +651 continue +641 continue +621 continue + goto 601 +600 continue + if (.not.(ctod (memc(str1), ip, equinx) .le. 0)) goto 670 + ctype = 0 + radecs = 0 + equinx = 1.6d308 + epoch = 1.6d308 + goto 671 +670 continue + if (.not.(equinx .lt. 1984.0d0)) goto 680 + radecs = 1 + call gargwd (memc(str2), 1023 ) + if (.not.(nscan() .le. nitems)) goto 690 + epoch = sleb2d (equinx) + goto 691 +690 continue + if (.not.(memc(str2) .eq. 74 .or. memc(str2) .eq. + * 106 .or. memc(str2) .eq. 66 .or. memc(str2) .eq. 98 + * )) goto 700 + ip = 2 + goto 701 +700 continue + ip = 1 +701 continue + if (.not.(ctod (memc(str2), ip, epoch) .le. 0)) + * goto 710 + epoch = sleb2d (equinx) + goto 711 +710 continue + if (.not.(epoch .le. 3000.0d0 .and. (memc(str2) .eq + * . 74 .or. memc(str2) .eq. 106))) goto 720 + epoch = slej2d (epoch) + goto 721 +720 continue + if (.not.(epoch .gt. 3000.0d0)) goto 730 + epoch = epoch - 2400000.5d0 + goto 731 +730 continue + epoch = sleb2d (epoch) +731 continue +721 continue +711 continue +691 continue + goto 681 +680 continue + radecs = 3 + call gargwd (memc(str2), 1023 ) + if (.not.(nscan() .le. nitems)) goto 740 + epoch = slej2d (equinx) + goto 741 +740 continue + if (.not.(memc(str2) .eq. 74 .or. memc(str2) .eq. + * 106 .or. memc(str2) .eq. 66 .or. memc(str2) .eq. 98 + * )) goto 750 + ip = 2 + goto 751 +750 continue + ip = 1 +751 continue + if (.not.(ctod (memc(str2), ip, epoch) .le. 0)) + * goto 760 + epoch = slej2d (equinx) + goto 761 +760 continue + if (.not.(epoch .le. 3000.0d0 .and. (memc(str2) .eq + * . 66 .or. memc(str2) .eq. 98))) goto 770 + epoch = sleb2d (epoch) + goto 771 +770 continue + if (.not.(epoch .gt. 3000.0d0)) goto 780 + epoch = epoch - 2400000.5d0 + goto 781 +780 continue + epoch = slej2d (epoch) +781 continue +771 continue +761 continue +741 continue +681 continue +671 continue +601 continue +521 continue + goto 251 +250 continue + if (sw0003.lt.1.or.sw0003.gt.5) goto 510 + goto (260,260,350,350,440),sw0003 +251 continue + goto 231 +790 continue + if (.not.(memc(str1) .eq. 74 .or. memc(str1) .eq. 106 .or. + * memc(str1) .eq. 66 .or. memc(str1) .eq. 98)) goto 800 + ip = 2 + goto 801 +800 continue + ip = 1 +801 continue + if (.not.(ctod (memc(str1), ip, epoch) .le. 0)) goto 810 + epoch = 1.6d308 + goto 811 +810 continue + if (.not.(epoch .le. 3000.0d0)) goto 820 + if (.not.(memc(str1) .eq. 66 .or. memc(str1) .eq. 98)) + * goto 830 + epoch = sleb2d (epoch) + goto 831 +830 continue + if (.not.(memc(str1) .eq. 74 .or. memc(str1) .eq. 106)) + * goto 840 + epoch = slej2d (epoch) + goto 841 +840 continue + if (.not.(epoch .lt. 1984.0d0)) goto 850 + epoch = sleb2d (epoch) + goto 851 +850 continue + epoch = slej2d (epoch) +851 continue +841 continue +831 continue + goto 821 +820 continue + epoch = epoch - 2400000.5d0 +821 continue +811 continue + goto 231 +860 continue + if (.not.(memc(str1) .eq. 74 .or. memc(str1) .eq. 106 .or. + * memc(str1) .eq. 66 .or. memc(str1) .eq. 98)) goto 870 + ip = 2 + goto 871 +870 continue + ip = 1 +871 continue + if (.not.(ctod (memc(str1), ip, epoch) .le. 0)) goto 880 + epoch = sleb2d (1950.0d0) + goto 881 +880 continue + if (.not.(epoch .le. 3000.0d0)) goto 890 + if (.not.(memc(str1) .eq. 74 .or. memc(str1) .eq. 106)) + * goto 900 + epoch = slej2d (epoch) + goto 901 +900 continue + if (.not.(memc(str1) .eq. 66 .or. memc(str1) .eq. 98)) + * goto 910 + epoch = sleb2d (epoch) + goto 911 +910 continue + if (.not.(epoch .lt. 1984.0d0)) goto 920 + epoch = sleb2d (epoch) + goto 921 +920 continue + epoch = slej2d (epoch) +921 continue +911 continue +901 continue + goto 891 +890 continue + epoch = epoch - 2400000.5d0 +891 continue +881 continue + goto 231 +230 continue + if (sw0002.lt.1.or.sw0002.gt.4) goto 231 + goto (240,790,860,860),sw0002 +231 continue + if (.not.(ctype .eq. 0)) goto 930 + stat = -1 + goto 931 +930 continue + if (.not.(ctype .eq. 1 .and. (radecs .eq. 0 .or. ((equinx).eq.1 + * .6d308) .or. ((epoch).eq.1.6d308)))) goto 940 + stat = -1 + goto 941 +940 continue + if (.not.(ctype .eq. 2 .and. ((epoch).eq.1.6d308))) goto 950 + stat = -1 + goto 951 +950 continue + stat = 0 +951 continue +941 continue +931 continue + call sfree (sp) + skstrs = (stat) + goto 100 +100 return + end + integer function skimws (im, mw, ctype, lngax, latax, wtype, + *radecs, equinx, epoch) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer im + integer mw + integer ctype + integer lngax + integer latax + integer wtype + integer radecs + double precision equinx + double precision epoch + integer i + integer ndim + integer axtype + integer day + integer month + integer year + integer ier + integer oldfis + integer sp + integer atval + double precision hours + double precision imgetd + double precision sleb2d + double precision slej2d + integer mwstai + integer strdic + integer dtmdee + logical xerpop + logical xerflg + common /xercom/ xerflg + integer sw0001,sw0002,sw0003 + integer*2 st0001(7) + integer*2 st0002(6) + integer*2 st0003(39) + integer*2 st0004(6) + integer*2 st0005(6) + integer*2 st0006(7) + integer*2 st0007(114) + integer*2 st0008(8) + integer*2 st0009(6) + integer*2 st0010(9) + integer*2 st0011(30) + integer*2 st0012(8) + integer*2 st0013(8) + integer*2 st0014(9) + integer*2 st0015(8) + integer*2 st0016(8) + integer*2 st0017(9) + integer*2 st0018(8) + integer*2 st0019(8) + integer*2 st0020(9) + save + integer iyy + data st0001 / 97,120,116,121,112,101, 0/ + data st0002 / 73, 78, 68, 69, 70, 0/ + data (st0003(iyy),iyy= 1, 8) /124,114, 97,124,100,101, 99,124/ + data (st0003(iyy),iyy= 9,16) /103,108,111,110,124,103,108, 97/ + data (st0003(iyy),iyy=17,24) /116,124,101,108,111,110,124,101/ + data (st0003(iyy),iyy=25,32) /108, 97,116,124,115,108,111,110/ + data (st0003(iyy),iyy=33,39) /124,115,108, 97,116,124, 0/ + data st0004 /119,116,121,112,101, 0/ + data st0005 /119,116,121,112,101, 0/ + data st0006 /108,105,110,101, 97,114, 0/ + data (st0007(iyy),iyy= 1, 8) /124,108,105,110,124, 97,122,112/ + data (st0007(iyy),iyy= 9,16) /124,116, 97,110,124,115,105,110/ + data (st0007(iyy),iyy=17,24) /124,115,116,103,124, 97,114, 99/ + data (st0007(iyy),iyy=25,32) /124,122,112,110,124,122,101, 97/ + data (st0007(iyy),iyy=33,40) /124, 97,105,114,124, 99,121,112/ + data (st0007(iyy),iyy=41,48) /124, 99, 97,114,124,109,101,114/ + data (st0007(iyy),iyy=49,56) /124, 99,101, 97,124, 99,111,112/ + data (st0007(iyy),iyy=57,64) /124, 99,111,100,124, 99,111,101/ + data (st0007(iyy),iyy=65,72) /124, 99,111,111,124, 98,111,110/ + data (st0007(iyy),iyy=73,80) /124,112, 99,111,124,103,108,115/ + data (st0007(iyy),iyy=81,88) /124,112, 97,114,124, 97,105,116/ + data (st0007(iyy),iyy=89,96) /124,109,111,108,124, 99,115, 99/ + data (st0007(iyy),iyy=97,104) /124,113,115, 99,124,116,115, 99/ + data (st0007(iyy),iyy=105,112) /124,116,110,120,124,122,112,120/ + data (st0007(iyy),iyy=113,114) /124, 0/ + data st0008 / 69, 81, 85, 73, 78, 79, 88, 0/ + data st0009 / 69, 80, 79, 67, 72, 0/ + data (st0010(iyy),iyy= 1, 8) / 82, 65, 68, 69, 67, 83, 89, 83/ + data (st0010(iyy),iyy= 9, 9) / 0/ + data (st0011(iyy),iyy= 1, 8) /124,102,107, 52,124,102,107, 52/ + data (st0011(iyy),iyy= 9,16) / 45,110,111, 45,101,124,102,107/ + data (st0011(iyy),iyy=17,24) / 53,124,105, 99,114,115,124,103/ + data (st0011(iyy),iyy=25,30) / 97,112,112,116,124, 0/ + data st0012 / 77, 74, 68, 45, 87, 67, 83, 0/ + data st0013 / 77, 74, 68, 45, 79, 66, 83, 0/ + data (st0014(iyy),iyy= 1, 8) / 68, 65, 84, 69, 45, 79, 66, 83/ + data (st0014(iyy),iyy= 9, 9) / 0/ + data st0015 / 77, 74, 68, 45, 87, 67, 83, 0/ + data st0016 / 77, 74, 68, 45, 79, 66, 83, 0/ + data (st0017(iyy),iyy= 1, 8) / 68, 65, 84, 69, 45, 79, 66, 83/ + data (st0017(iyy),iyy= 9, 9) / 0/ + data st0018 / 77, 74, 68, 45, 87, 67, 83, 0/ + data st0019 / 77, 74, 68, 45, 79, 66, 83, 0/ + data (st0020(iyy),iyy= 1, 8) / 68, 65, 84, 69, 45, 79, 66, 83/ + data (st0020(iyy),iyy= 9, 9) / 0/ + call smark (sp) + call salloc (atval, 1023 , 2) + ctype = 0 + lngax = 0 + latax = 0 + wtype = 0 + radecs = 0 + equinx = 1.6d308 + epoch = 1.6d308 + ndim = mwstai (mw, 5 ) + do 110 i = 1, ndim + call xerpsh + call mwgwas (mw, i, st0001, memc(atval), 1023 ) + if (.not.xerpop()) goto 120 + call xstrcy(st0002, memc(atval), 1023 ) +120 continue + axtype = strdic (memc(atval), memc(atval), 1023 , st0003) + sw0001=(axtype) + goto 130 +140 continue + ctype = 1 + goto 131 +150 continue + ctype = 2 + goto 131 +160 continue + ctype = 3 + goto 131 +170 continue + ctype = 4 + goto 131 +180 continue + goto 131 +130 continue + if (sw0001.lt.1.or.sw0001.gt.8) goto 180 + goto (140,140,160,160,150,150,170,170),sw0001 +131 continue + sw0002=(axtype) + goto 190 +200 continue + lngax = i + goto 191 +210 continue + latax = i + goto 191 +220 continue + goto 191 +190 continue + if (sw0002.lt.1.or.sw0002.gt.8) goto 220 + goto (200,210,200,210,200,210,200,210),sw0002 +191 continue +110 continue +111 continue + if (.not.(ctype .eq. 0 .or. lngax .eq. 0 .or. latax .eq. 0)) + * goto 230 + call sfree (sp) + skimws = (-1) + goto 100 +230 continue + call xerpsh + call mwgwas (mw, lngax, st0004, memc(atval), 1023 ) + if (xerflg) goto 242 +242 if (.not.xerpop()) goto 240 + call xerpsh + call mwgwas(mw, latax, st0005, memc(atval), 1023 ) + if (.not.xerpop()) goto 250 + call xstrcy(st0006, memc(atval), 1023 ) +250 continue +240 continue + wtype = strdic (memc(atval), memc(atval), 1023 , st0007) + if (.not.(wtype .eq. 0)) goto 260 + call sfree (sp) + skimws = (-1) + goto 100 +260 continue + if (.not.(ctype .eq. 1)) goto 270 + call xerpsh + equinx = imgetd (im, st0008) + if (xerflg) goto 282 +282 if (.not.xerpop()) goto 280 + call xerpsh + equinx = imgetd (im, st0009) + if (xerflg) goto 292 +292 if (.not.xerpop()) goto 290 + equinx = 1.6d308 +290 continue +280 continue + call xerpsh + call imgstr (im, st0010, memc(atval), 1023 ) + if (xerflg) goto 302 +302 if (.not.xerpop()) goto 300 + radecs = 0 + goto 301 +300 continue + call strlwr (memc(atval)) + radecs = strdic (memc(atval), memc(atval), 1023 , st0011) +301 continue + if (.not.(radecs .eq. 0)) goto 310 + if (.not.(((equinx).eq.1.6d308))) goto 320 + radecs = 3 + goto 321 +320 continue + if (.not.(equinx .lt. 1984.0d0)) goto 330 + radecs = 1 + goto 331 +330 continue + radecs = 3 +331 continue +321 continue +310 continue + call xerpsh + epoch = imgetd (im, st0012) + if (xerflg) goto 342 +342 if (.not.xerpop()) goto 340 + call xerpsh + epoch = imgetd (im, st0013) + if (xerflg) goto 352 +352 if (.not.xerpop()) goto 350 + call xerpsh + call imgstr (im, st0014, memc(atval), 1023 ) + if (xerflg) goto 362 +362 if (.not.xerpop()) goto 360 + epoch = 1.6d308 + goto 361 +360 continue + if (.not.(dtmdee (memc(atval), year, month, day, hours + * , oldfis) .eq. 0)) goto 370 + call slcadj (year, month, day, epoch, ier) + if (.not.(ier .ne. 0)) goto 380 + epoch = 1.6d308 + goto 381 +380 continue + if (.not.(.not. ((hours).eq.1.6d308) .and. hours . + * ge. 0.0d0 .and. hours .le. 24.0d0)) goto 390 + epoch = epoch + hours / 24.0d0 +390 continue +381 continue + goto 371 +370 continue + epoch = 1.6d308 +371 continue +361 continue +350 continue +340 continue + sw0003=(radecs) + goto 400 +410 continue + if (.not.(((equinx).eq.1.6d308))) goto 420 + equinx = 1950.0d0 +420 continue + if (.not.(((epoch).eq.1.6d308))) goto 430 + epoch = sleb2d (1950.0d0) +430 continue + goto 401 +440 continue + if (.not.(((equinx).eq.1.6d308))) goto 450 + equinx = 2000.0d0 +450 continue + if (.not.(((epoch).eq.1.6d308))) goto 460 + epoch = slej2d (2000.0d0) +460 continue + goto 401 +470 continue + equinx = 2000.0d0 + goto 401 +400 continue + if (sw0003.lt.1.or.sw0003.gt.5) goto 401 + goto (410,410,440,440,470),sw0003 +401 continue + if (.not.(((epoch).eq.1.6d308))) goto 480 + call sfree (sp) + skimws = (-1) + goto 100 +480 continue +270 continue + if (.not.(ctype .eq. 2)) goto 490 + call xerpsh + epoch = imgetd (im, st0015) + if (xerflg) goto 502 +502 if (.not.xerpop()) goto 500 + call xerpsh + epoch = imgetd (im, st0016) + if (xerflg) goto 512 +512 if (.not.xerpop()) goto 510 + call xerpsh + call imgstr (im, st0017, memc(atval), 1023 ) + if (xerflg) goto 522 +522 if (.not.xerpop()) goto 520 + epoch = 1.6d308 + goto 521 +520 continue + if (.not.(dtmdee (memc(atval), year, month, day, hours + * , oldfis) .eq. 0)) goto 530 + call slcadj (year, month, day, epoch, ier) + if (.not.(ier .ne. 0)) goto 540 + epoch = 1.6d308 + goto 541 +540 continue + if (.not.(.not. ((hours).eq.1.6d308) .and. hours . + * ge. 0.0d0 .and. hours .le. 24.0d0)) goto 550 + epoch = epoch + hours / 24.0d0 +550 continue +541 continue + goto 531 +530 continue + epoch = 1.6d308 +531 continue +521 continue +510 continue +500 continue + if (.not.(((epoch).eq.1.6d308))) goto 560 + call sfree (sp) + skimws = (-1) + goto 100 +560 continue +490 continue + if (.not.(ctype .eq. 3 .or. ctype .eq. 4)) goto 570 + call xerpsh + epoch = imgetd (im, st0018) + if (xerflg) goto 582 +582 if (.not.xerpop()) goto 580 + call xerpsh + epoch = imgetd (im, st0019) + if (xerflg) goto 592 +592 if (.not.xerpop()) goto 590 + call xerpsh + call imgstr (im, st0020, memc(atval), 1023 ) + if (xerflg) goto 602 +602 if (.not.xerpop()) goto 600 + epoch = sleb2d (1950.0d0) + goto 601 +600 continue + if (.not.(dtmdee (memc(atval), year, month, day, hours + * , oldfis) .eq. 0)) goto 610 + call slcadj (year, month, day, epoch, ier) + if (.not.(ier .ne. 0)) goto 620 + epoch = sleb2d (1950.0d0) + goto 621 +620 continue + if (.not.(.not. ((hours).eq.1.6d308) .and. hours + * .ge. 0.0d0 .and. hours .le. 24.0d0)) goto 630 + epoch = epoch + hours / 24.0d0 +630 continue +621 continue + goto 611 +610 continue + epoch = sleb2d (1950.0d0) +611 continue +601 continue +590 continue +580 continue +570 continue + call sfree (sp) + skimws = (0) + goto 100 +100 return + end + subroutine skenws (coo, wcsstr, maxch) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer coo + integer maxch + integer*2 wcsstr(*) + double precision skstad + double precision slepj + double precision slepb + integer skstai + integer sw0001,sw0002 + integer*2 st0001(9) + integer*2 st0002(16) + integer*2 st0003(18) + integer*2 st0004(19) + integer*2 st0005(18) + integer*2 st0006(21) + integer*2 st0007(9) + integer*2 st0008(16) + integer*2 st0009(16) + integer*2 st0010(21) + save + integer iyy + data (st0001(iyy),iyy= 1, 8) / 97,112,112, 97,114,101,110,116/ + data (st0001(iyy),iyy= 9, 9) / 0/ + data (st0002(iyy),iyy= 1, 8) / 97,112,112, 97,114,101,110,116/ + data (st0002(iyy),iyy= 9,16) / 32, 74, 37, 48, 46, 56,102, 0/ + data (st0003(iyy),iyy= 1, 8) /102,107, 53, 32, 74, 37, 48, 46/ + data (st0003(iyy),iyy= 9,16) / 51,102, 32, 74, 37, 48, 46, 56/ + data (st0003(iyy),iyy=17,18) /102, 0/ + data (st0004(iyy),iyy= 1, 8) /105, 99,114,115, 32, 74, 37, 48/ + data (st0004(iyy),iyy= 9,16) / 46, 51,102, 32, 74, 37, 48, 46/ + data (st0004(iyy),iyy=17,19) / 56,102, 0/ + data (st0005(iyy),iyy= 1, 8) /102,107, 52, 32, 66, 37, 48, 46/ + data (st0005(iyy),iyy= 9,16) / 51,102, 32, 66, 37, 48, 46, 56/ + data (st0005(iyy),iyy=17,18) /102, 0/ + data (st0006(iyy),iyy= 1, 8) /102,107, 52,110,111,101, 32, 66/ + data (st0006(iyy),iyy= 9,16) / 37, 48, 46, 51,102, 32, 66, 37/ + data (st0006(iyy),iyy=17,21) / 48, 46, 56,102, 0/ + data (st0007(iyy),iyy= 1, 8) /101, 99,108,105,112,116,105, 99/ + data (st0007(iyy),iyy= 9, 9) / 0/ + data (st0008(iyy),iyy= 1, 8) /101, 99,108,105,112,116,105, 99/ + data (st0008(iyy),iyy= 9,16) / 32, 74, 37, 48, 46, 56,102, 0/ + data (st0009(iyy),iyy= 1, 8) /103, 97,108, 97, 99,116,105, 99/ + data (st0009(iyy),iyy= 9,16) / 32, 74, 37, 48, 46, 56,102, 0/ + data (st0010(iyy),iyy= 1, 8) /115,117,112,101,114,103, 97,108/ + data (st0010(iyy),iyy= 9,16) / 97, 99,116,105, 99, 32,106, 37/ + data (st0010(iyy),iyy=17,21) / 48, 46, 56,102, 0/ + sw0001=(skstai (coo, 7)) + goto 110 +120 continue + sw0002=(skstai(coo, 8)) + goto 130 +140 continue + if (.not.(((skstad(coo, 6)).eq.1.6d308))) goto 150 + call sprinf (wcsstr, maxch, st0001) + goto 151 +150 continue + call sprinf (wcsstr, maxch, st0002) + call pargd (slepj(skstad(coo, 6))) +151 continue + goto 131 +160 continue + call sprinf (wcsstr, maxch, st0003) + call pargd (skstad(coo, 5)) + call pargd (slepj(skstad(coo, 6))) + goto 131 +170 continue + call sprinf (wcsstr, maxch, st0004) + call pargd (skstad(coo, 5)) + call pargd (slepj(skstad(coo, 6))) + goto 131 +180 continue + call sprinf (wcsstr, maxch, st0005) + call pargd (skstad(coo, 5)) + call pargd (slepb(skstad(coo, 6))) + goto 131 +190 continue + call sprinf (wcsstr, maxch, st0006) + call pargd (skstad(coo, 5)) + call pargd (slepb(skstad(coo, 6))) + goto 131 +200 continue + wcsstr(1) = 0 + goto 131 +130 continue + if (sw0002.lt.1.or.sw0002.gt.5) goto 200 + goto (180,190,160,170,140),sw0002 +131 continue + goto 111 +210 continue + if (.not.(((skstad(coo, 6)).eq.1.6d308))) goto 220 + call sprinf (wcsstr, maxch, st0007) + goto 221 +220 continue + call sprinf (wcsstr, maxch, st0008) + call pargd (slepj(skstad(coo, 6))) +221 continue + goto 111 +230 continue + call sprinf (wcsstr, maxch, st0009) + call pargd (slepj(skstad(coo, 6))) + goto 111 +240 continue + call sprinf (wcsstr, maxch, st0010) + call pargd (slepj(skstad(coo, 6))) + goto 111 +110 continue + if (sw0001.lt.1.or.sw0001.gt.4) goto 111 + goto (120,210,230,240),sw0001 +111 continue +100 return + end + integer function skcopy (cooin) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer cooin + integer cooout + save + if (.not.(cooin .eq. 0)) goto 110 + cooout = 0 + goto 111 +110 continue + call xcallc(cooout, (30 + 255 + 1), 10 ) + memd((((cooout)-1)/2+1)) = memd((((cooin)-1)/2+1)) + memd((((cooout+2)-1)/2+1)) = memd((((cooin+2)-1)/2+1)) + memd((((cooout+4)-1)/2+1)) = memd((((cooin+4)-1)/2+1)) + memd((((cooout+6)-1)/2+1)) = memd((((cooin+6)-1)/2+1)) + memd((((cooout+8)-1)/2+1)) = memd((((cooin+8)-1)/2+1)) + memd((((cooout+10)-1)/2+1)) = memd((((cooin+10)-1)/2+1)) + memi(cooout+12) = memi(cooin+12) + memi(cooout+13) = memi(cooin+13) + memi(cooout+14) = memi(cooin+14) + memi(cooout+15) = memi(cooin+15) + memi(cooout+16) = memi(cooin+16) + memi(cooout+17) = memi(cooin+17) + memi(cooout+18) = memi(cooin+18) + memi(cooout+19) = memi(cooin+19) + memi(cooout+20) = memi(cooin+20) + memi(cooout+21) = memi(cooin+21) + memi(cooout+22) = memi(cooin+22) + memi(cooout+23) = memi(cooin+23) + call xstrcy(memc((((cooin+25)-1)*2+1)) , memc((((cooout+25)- + * 1)*2+1)) , 255 ) +111 continue + skcopy = (cooout) + goto 100 +100 return + end + subroutine skcloe (coo) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer coo + save + if (.not.(coo .ne. 0)) goto 110 + call xmfree(coo, 10 ) +110 continue +100 return + end +c sprinf sprintf +c dtmdee dtm_decode +c skenws sk_enwcs +c skstad sk_statd +c radecs radecsys +c equinx equinox +c skdecs sk_decwcs +c skimws sk_imwcs +c skstrs sk_strwcs +c skdecr sk_decwstr +c skstai sk_stati +c mwstai mw_stati +c skdecm sk_decim +c mwgaxp mw_gaxmap +c gargwd gargwrd +c sleb2d sl_eb2d +c mwopem mw_openim +c oldfis oldfits +c imunmp imunmap +c mwgwas mw_gwattrs +c skcopy sk_copy +c slej2d sl_ej2d +c srades sradecsys +c slcadj sl_cadj +c skcloe sk_close +c pargsr pargstr +c mwcloe mw_close diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skdecode.x b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skdecode.x new file mode 100644 index 00000000..5fa88f3b --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skdecode.x @@ -0,0 +1,999 @@ +include <imio.h> +include <imhdr.h> +include <mwset.h> +include "skywcs.h" +include "skywcsdef.h" + +# SK_DECWCS -- Decode the wcs string which may be either an image name +# plus wcs, e.g. "dev$pix logical" or a string describing the celestial +# coordinate system, e.g. "J2000" or "galactic" into a celestial coordinate +# structure. If the input wcs is an image wcs then a non-NULL pointer to +# the image wcs structure is also returned. ERR is returned if a valid +# celestial coordinate structure cannot be created. + +int procedure sk_decwcs (instr, mw, coo, imcoo) + +char instr[ARB] #I the input wcs string +pointer mw #O the pointer to the image wcs structure +pointer coo #O the pointer to the coordinate structure +pointer imcoo #I pointer to an existing coordinate structure + +int stat +pointer sp, str1, str2, laxno, paxval, im +int sk_strwcs(), sk_decim() +pointer immap() +errchk immap() + +begin + call calloc (coo, LEN_SKYCOOSTRUCT, TY_STRUCT) + call strcpy (instr, SKY_COOSYSTEM(coo), SZ_FNAME) + + # Allocate some working space. + call smark (sp) + call salloc (str1, SZ_LINE, TY_CHAR) + call salloc (str2, SZ_LINE, TY_CHAR) + call salloc (laxno, IM_MAXDIM, TY_INT) + call salloc (paxval, IM_MAXDIM, TY_INT) + + # Decode the wcs. + call sscan (instr) + call gargwrd (Memc[str1], SZ_LINE) + call gargwrd (Memc[str2], SZ_LINE) + + # First try to open an image wcs. + iferr { + im = immap (Memc[str1], READ_ONLY, 0) + + # Decode the user wcs. + } then { + + # Initialize. + mw = NULL + if (imcoo == NULL) { + SKY_NLNGAX(coo) = 2048 + SKY_NLATAX(coo) = 2048 + SKY_PLNGAX(coo) = 1 + SKY_PLATAX(coo) = 2 + SKY_XLAX(coo) = 1 + SKY_YLAX(coo) = 2 + SKY_VXOFF(coo) = 0.0d0 + SKY_VYOFF(coo) = 0.0d0 + SKY_VXSTEP(coo) = 1.0d0 + SKY_VYSTEP(coo) = 1.0d0 + SKY_WTYPE(coo) = 0 + } else { + SKY_NLNGAX(coo) = SKY_NLNGAX(imcoo) + SKY_NLATAX(coo) = SKY_NLATAX(imcoo) + SKY_PLNGAX(coo) = SKY_PLNGAX(imcoo) + SKY_PLATAX(coo) = SKY_PLATAX(imcoo) + SKY_XLAX(coo) = SKY_XLAX(imcoo) + SKY_YLAX(coo) = SKY_YLAX(imcoo) + SKY_VXOFF(coo) = SKY_VXOFF(imcoo) + SKY_VYOFF(coo) = SKY_VYOFF(imcoo) + SKY_VXSTEP(coo) = SKY_VXSTEP(imcoo) + SKY_VYSTEP(coo) = SKY_VYSTEP(imcoo) + SKY_WTYPE(coo) = SKY_WTYPE(imcoo) + } + SKY_PIXTYPE(coo) = PIXTYPE_WORLD + + # Decode the actual wcs. + stat = sk_strwcs (instr, SKY_CTYPE(coo), SKY_RADECSYS(coo), + SKY_EQUINOX(coo), SKY_EPOCH(coo)) + switch (SKY_CTYPE(coo)) { + case CTYPE_EQUATORIAL: + SKY_NLNGUNITS(coo) = SKY_HOURS + SKY_NLATUNITS(coo) = SKY_DEGREES + default: + SKY_NLNGUNITS(coo) = SKY_DEGREES + SKY_NLATUNITS(coo) = SKY_DEGREES + } + + # Decode the image wcs. + } else { + stat = sk_decim (im, Memc[str2], mw, coo) + call imunmap (im) + } + + call sfree (sp) + + SKY_STATUS(coo) = stat + return (stat) +end + + +# SK_DECWSTR -- Decode the wcs string coordinate system, e.g. "J2000" or +# "galactic" into a celestial coordinate structure. ERR is returned if a +# valid celestial coordinate structure cannot be created. + +int procedure sk_decwstr (instr, coo, imcoo) + +char instr[ARB] #I the input wcs string +pointer coo #O the pointer to the coordinate structure +pointer imcoo #I pointer to an existing coordinate structure + +int stat +int sk_strwcs() + +begin + call calloc (coo, LEN_SKYCOOSTRUCT, TY_STRUCT) + call strcpy (instr, SKY_COOSYSTEM(coo), SZ_FNAME) + + # Initialize. + if (imcoo == NULL) { + SKY_NLNGAX(coo) = 2048 + SKY_NLATAX(coo) = 2048 + SKY_PLNGAX(coo) = 1 + SKY_PLATAX(coo) = 2 + SKY_XLAX(coo) = 1 + SKY_YLAX(coo) = 2 + SKY_VXOFF(coo) = 0.0d0 + SKY_VYOFF(coo) = 0.0d0 + SKY_VXSTEP(coo) = 1.0d0 + SKY_VYSTEP(coo) = 1.0d0 + SKY_WTYPE(coo) = 0 + } else { + SKY_NLNGAX(coo) = SKY_NLNGAX(imcoo) + SKY_NLATAX(coo) = SKY_NLATAX(imcoo) + SKY_PLNGAX(coo) = SKY_PLNGAX(imcoo) + SKY_PLATAX(coo) = SKY_PLATAX(imcoo) + SKY_XLAX(coo) = SKY_XLAX(imcoo) + SKY_YLAX(coo) = SKY_YLAX(imcoo) + SKY_VXOFF(coo) = SKY_VXOFF(imcoo) + SKY_VYOFF(coo) = SKY_VYOFF(imcoo) + SKY_VXSTEP(coo) = SKY_VXSTEP(imcoo) + SKY_VYSTEP(coo) = SKY_VYSTEP(imcoo) + SKY_WTYPE(coo) = SKY_WTYPE(imcoo) + } + SKY_PIXTYPE(coo) = PIXTYPE_WORLD + + # Decode the actual wcs. + stat = sk_strwcs (instr, SKY_CTYPE(coo), SKY_RADECSYS(coo), + SKY_EQUINOX(coo), SKY_EPOCH(coo)) + switch (SKY_CTYPE(coo)) { + case CTYPE_EQUATORIAL: + SKY_NLNGUNITS(coo) = SKY_HOURS + SKY_NLATUNITS(coo) = SKY_DEGREES + default: + SKY_NLNGUNITS(coo) = SKY_DEGREES + SKY_NLATUNITS(coo) = SKY_DEGREES + } + + SKY_STATUS(coo) = stat + + return (stat) +end + + +# SK_DECIM -- Given an image descriptor and an image wcs string create a +# celstial coordinate structure. A non-NULL pointer to the image wcs structure +# is also returned. ERR is returned if a valid celestial coordinate descriptor +# cannot be created. + + +int procedure sk_decim (im, wcs, mw, coo) + +pointer im #I the pointer to the input image +char wcs[ARB] #I the wcs string [logical|tv|physical|world] +pointer mw #O the pointer to the image wcs structure +pointer coo #O the pointer to the coordinate structure + +int stat +pointer sp, str1, laxno, paxval +int sk_imwcs(), strdic(), mw_stati() +pointer mw_openim() +errchk mw_openim() + +begin + call malloc (coo, LEN_SKYCOOSTRUCT, TY_STRUCT) + call sprintf (SKY_COOSYSTEM(coo), SZ_FNAME, "%s %s") + call pargstr (IM_HDRFILE(im)) + call pargstr (wcs) + + call smark (sp) + call salloc (str1, SZ_LINE, TY_CHAR) + call salloc (laxno, IM_MAXDIM, TY_INT) + call salloc (paxval, IM_MAXDIM, TY_INT) + + # Try to open the image wcs. + iferr { + mw = mw_openim (im) + + # Set up a dummy wcs. + } then { + + #Initialize. + SKY_CTYPE(coo) = 0 + SKY_RADECSYS(coo) = 0 + SKY_EQUINOX(coo) = INDEFD + SKY_EPOCH(coo) = INDEFD + mw = NULL + SKY_PLNGAX(coo) = 1 + SKY_PLATAX(coo) = 2 + SKY_XLAX(coo) = 1 + SKY_YLAX(coo) = 2 + SKY_NLNGAX(coo) = 2048 + SKY_NLATAX(coo) = 2048 + SKY_VXOFF(coo) = 0.0d0 + SKY_VYOFF(coo) = 0.0d0 + SKY_VXSTEP(coo) = 1.0d0 + SKY_VYSTEP(coo) = 1.0d0 + SKY_WTYPE(coo) = 0 + SKY_PIXTYPE(coo) = PIXTYPE_LOGICAL + SKY_NLNGUNITS(coo) = SKY_DEGREES + SKY_NLATUNITS(coo) = SKY_DEGREES + stat = ERR + + # Decode the wcs. + } else { + SKY_PIXTYPE(coo) = strdic (wcs, Memc[str1], SZ_LINE, PIXTYPE_LIST) + if (SKY_PIXTYPE(coo) <= 0) + SKY_PIXTYPE(coo) = PIXTYPE_LOGICAL + if (sk_imwcs (im, mw, SKY_CTYPE(coo), SKY_PLNGAX(coo), + SKY_PLATAX(coo), SKY_WTYPE(coo), SKY_RADECSYS(coo), + SKY_EQUINOX(coo), SKY_EPOCH(coo)) == OK) { + switch (SKY_CTYPE(coo)) { + case CTYPE_EQUATORIAL: + SKY_NLNGUNITS(coo) = SKY_HOURS + SKY_NLATUNITS(coo) = SKY_DEGREES + default: + SKY_NLNGUNITS(coo) = SKY_DEGREES + SKY_NLATUNITS(coo) = SKY_DEGREES + } + call mw_gaxmap (mw, Memi[laxno], Memi[paxval], mw_stati(mw, + MW_NPHYSDIM)) + if (Memi[laxno+SKY_PLNGAX(coo)-1] < + Memi[laxno+SKY_PLATAX(coo)-1]) { + SKY_XLAX(coo) = Memi[laxno+SKY_PLNGAX(coo)-1] + SKY_YLAX(coo) = Memi[laxno+SKY_PLATAX(coo)-1] + } else { + SKY_XLAX(coo) = Memi[laxno+SKY_PLATAX(coo)-1] + SKY_YLAX(coo) = Memi[laxno+SKY_PLNGAX(coo)-1] + } + if (SKY_XLAX(coo) <= 0 || SKY_YLAX(coo) <= 0) { + SKY_VXOFF(coo) = 0.0d0 + SKY_VYOFF(coo) = 0.0d0 + SKY_VXSTEP(coo) = 1.0d0 + SKY_VYSTEP(coo) = 1.0d0 + SKY_NLNGAX(coo) = 2048 + SKY_NLATAX(coo) = 2048 + stat = ERR + } else { + SKY_VXOFF(coo) = IM_VOFF(im,IM_VMAP(im,SKY_XLAX(coo))) + SKY_VYOFF(coo) = IM_VOFF(im,IM_VMAP(im,SKY_YLAX(coo))) + SKY_VXSTEP(coo) = IM_VSTEP(im,SKY_XLAX(coo)) + SKY_VYSTEP(coo) = IM_VSTEP(im,SKY_YLAX(coo)) + SKY_NLNGAX(coo) = IM_LEN(im,SKY_XLAX(coo)) + SKY_NLATAX(coo) = IM_LEN(im,SKY_YLAX(coo)) + stat = OK + } + } else { + call mw_close (mw) + mw = NULL + SKY_XLAX(coo) = 1 + SKY_YLAX(coo) = 2 + SKY_NLNGAX(coo) = 2048 + SKY_NLATAX(coo) = 2048 + SKY_VXOFF(coo) = 0.0d0 + SKY_VYOFF(coo) = 0.0d0 + SKY_VXSTEP(coo) = 1.0d0 + SKY_VYSTEP(coo) = 1.0d0 + SKY_NLNGUNITS(coo) = SKY_DEGREES + SKY_NLATUNITS(coo) = SKY_DEGREES + stat = ERR + } + } + + call sfree (sp) + + SKY_STATUS(coo) = stat + return (stat) +end + + +# SK_STRWCS -- Decode the sky coordinate system from an input string. +# The string syntax is [ctype] equinox [epoch]. The various options +# have been placed case statements. Although there is considerable +# duplication of code in the case statements, there are minor differences +# and I found it clearer to write it out rather than trying to be +# concise. I might want to clean this up a bit later. + +int procedure sk_strwcs (instr, ctype, radecsys, equinox, epoch) + +char instr[ARB] #I the input wcs string +int ctype #O the output coordinate type +int radecsys #O the output equatorial reference system +double equinox #O the output equinox +double epoch #O the output epoch of the observation + +int ip, nitems, sctype, sradecsys, stat +pointer sp, str1, str2 +int strdic(), nscan(), ctod() +double sl_ej2d(), sl_epb(), sl_eb2d(), sl_epj() + +begin + # Initialize. + ctype = 0 + radecsys = 0 + equinox = INDEFD + epoch = INDEFD + + # Allocate working space. + call smark (sp) + call salloc (str1, SZ_LINE, TY_CHAR) + call salloc (str2, SZ_LINE, TY_CHAR) + + # Determine the coordinate string. + call sscan (instr) + call gargwrd (Memc[str1], SZ_LINE) + + # Return with an error if the string is blank. + if (Memc[str1] == EOS || nscan() < 1) { + call sfree (sp) + return (ERR) + } else + nitems = 1 + + # If the coordinate type is undefined temporarily default it to + # equatorial. + sctype = strdic (Memc[str1], Memc[str2], SZ_LINE, FTYPE_LIST) + if (sctype <= 0) { + ctype = CTYPE_EQUATORIAL + } else { + switch (sctype) { + case FTYPE_FK4: + ctype = CTYPE_EQUATORIAL + radecsys = EQTYPE_FK4 + case FTYPE_FK4NOE: + ctype = CTYPE_EQUATORIAL + radecsys = EQTYPE_FK4NOE + case FTYPE_FK5: + ctype = CTYPE_EQUATORIAL + radecsys = EQTYPE_FK5 + case FTYPE_ICRS: + ctype = CTYPE_EQUATORIAL + radecsys = EQTYPE_ICRS + case FTYPE_GAPPT: + ctype = CTYPE_EQUATORIAL + radecsys = EQTYPE_GAPPT + case FTYPE_ECLIPTIC: + ctype = CTYPE_ECLIPTIC + case FTYPE_GALACTIC: + ctype = CTYPE_GALACTIC + case FTYPE_SUPERGALACTIC: + ctype = CTYPE_SUPERGALACTIC + } + call gargwrd (Memc[str1], SZ_LINE) + if (nscan() > nitems) + nitems = nitems + 1 + } + sctype = ctype + sradecsys = radecsys + + # Decode the coordinate system. + switch (sctype) { + + # Decode the equatorial system, equinox, and epoch. + case CTYPE_EQUATORIAL: + + switch (sradecsys) { + case EQTYPE_FK4, EQTYPE_FK4NOE: + if (Memc[str1] == 'J' || Memc[str1] == 'j' || + Memc[str1] == 'B' || Memc[str1] == 'b') + ip = 2 + else + ip = 1 + if (ctod (Memc[str1], ip, equinox) <= 0) + equinox = 1950.0d0 + if (Memc[str1] == 'J' || Memc[str1] == 'j') + equinox = sl_epb (sl_ej2d (equinox)) + + call gargwrd (Memc[str2], SZ_LINE) + if (nscan() <= nitems) + epoch = sl_eb2d (equinox) + else { + if (Memc[str2] == 'J' || Memc[str2] == 'j' || + Memc[str2] == 'B' || Memc[str2] == 'b') + ip = 2 + else + ip = 1 + if (ctod (Memc[str2], ip, epoch) <= 0) + epoch = sl_eb2d (equinox) + else if (epoch <= 3000.0d0 && (Memc[str2] == 'J' || + Memc[str2] == 'j')) + epoch = sl_ej2d (epoch) + else if (epoch > 3000.0d0) + epoch = epoch - 2400000.5d0 + else + epoch = sl_eb2d (epoch) + } + + case EQTYPE_FK5, EQTYPE_ICRS: + if (Memc[str1] == 'J' || Memc[str1] == 'j' || + Memc[str1] == 'B' || Memc[str1] == 'b') + ip = 2 + else + ip = 1 + if (ctod (Memc[str1], ip, equinox) <= 0) + equinox = 2000.0d0 + if (Memc[str1] == 'B' || Memc[str1] == 'b') + equinox = sl_epj(sl_eb2d (equinox)) + + call gargwrd (Memc[str2], SZ_LINE) + if (nscan() <= nitems) + epoch = sl_ej2d (equinox) + else { + if (Memc[str2] == 'J' || Memc[str2] == 'j' || + Memc[str2] == 'B' || Memc[str2] == 'b') + ip = 2 + else + ip = 1 + if (ctod (Memc[str2], ip, epoch) <= 0) + epoch = sl_ej2d (equinox) + else if (epoch <= 3000.0d0 && (Memc[str2] == 'B' || + Memc[str2] == 'b')) + epoch = sl_eb2d (epoch) + else if (epoch > 3000.0d0) + epoch = epoch - 2400000.5d0 + else + epoch = sl_ej2d (epoch) + } + + case EQTYPE_GAPPT: + equinox = 2000.0d0 + if (Memc[str1] == 'J' || Memc[str1] == 'j' || + Memc[str1] == 'B' || Memc[str1] == 'b') + ip = 2 + else + ip = 1 + if (ctod (Memc[str1], ip, epoch) <= 0) { + epoch = INDEFD + } else if (epoch <= 3000.0d0) { + if (Memc[str1] == 'B' || Memc[str1] == 'b') + epoch = sl_eb2d (epoch) + else if (Memc[str1] == 'J' || Memc[str1] == 'j') + epoch = sl_ej2d (epoch) + else if (epoch < 1984.0d0) + epoch = sl_eb2d (epoch) + else + epoch = sl_ej2d (epoch) + } else { + epoch = epoch - 2400000.5d0 + } + + default: + ip = 1 + if (Memc[str1] == 'B' || Memc[str1] == 'b') { + radecsys = EQTYPE_FK4 + ip = ip + 1 + if (ctod (Memc[str1], ip, equinox) <= 0) + equinox = 1950.0d0 + + call gargwrd (Memc[str2], SZ_LINE) + if (nscan() <= nitems) + epoch = sl_eb2d (equinox) + else { + if (Memc[str2] == 'J' || Memc[str2] == 'j') + ip = 2 + else if (Memc[str2] == 'B' || Memc[str2] == 'b') + ip = 2 + else + ip = 1 + if (ctod (Memc[str2], ip, epoch) <= 0) + epoch = sl_eb2d (equinox) + else if (epoch <= 3000.0d0 && (Memc[str2] == 'J' || + Memc[str2] == 'j')) + epoch = sl_ej2d (epoch) + else if (epoch > 3000.0d0) + epoch = epoch - 2400000.5d0 + else + epoch = sl_eb2d (epoch) + } + + } else if (Memc[str1] == 'J' || Memc[str1] == 'j') { + radecsys = EQTYPE_FK5 + ip = ip + 1 + if (ctod (Memc[str1], ip, equinox) <= 0) + equinox = 2000.0d0 + + call gargwrd (Memc[str2], SZ_LINE) + if (nscan() <= nitems) + epoch = sl_ej2d (equinox) + else { + if (Memc[str2] == 'J' || Memc[str2] == 'j' || + Memc[str2] == 'B' || Memc[str2] == 'b') + ip = 2 + else + ip = 1 + if (ctod (Memc[str2], ip, epoch) <= 0) + epoch = sl_ej2d (equinox) + else if (epoch <= 3000.0d0 && (Memc[str2] == 'B' || + Memc[str2] == 'b')) + epoch = sl_eb2d (epoch) + else if (epoch > 3000.0d0) + epoch = epoch - 2400000.5d0 + else + epoch = sl_ej2d (epoch) + } + + } else if (ctod (Memc[str1], ip, equinox) <= 0) { + ctype = 0 + radecsys = 0 + equinox = INDEFD + epoch = INDEFD + + } else if (equinox < 1984.0d0) { + radecsys = EQTYPE_FK4 + call gargwrd (Memc[str2], SZ_LINE) + if (nscan() <= nitems) + epoch = sl_eb2d (equinox) + else { + if (Memc[str2] == 'J' || Memc[str2] == 'j' || + Memc[str2] == 'B' || Memc[str2] == 'b') + ip = 2 + else + ip = 1 + if (ctod (Memc[str2], ip, epoch) <= 0) + epoch = sl_eb2d (equinox) + else if (epoch <= 3000.0d0 && (Memc[str2] == 'J' || + Memc[str2] == 'j')) + epoch = sl_ej2d (epoch) + else if (epoch > 3000.0d0) + epoch = epoch - 2400000.5d0 + else + epoch = sl_eb2d (epoch) + } + + } else { + radecsys = EQTYPE_FK5 + call gargwrd (Memc[str2], SZ_LINE) + if (nscan() <= nitems) + epoch = sl_ej2d (equinox) + else { + if (Memc[str2] == 'J' || Memc[str2] == 'j' || + Memc[str2] == 'B' || Memc[str2] == 'b') + ip = 2 + else + ip = 1 + if (ctod (Memc[str2], ip, epoch) <= 0) + epoch = sl_ej2d (equinox) + else if (epoch <= 3000.0d0 && (Memc[str2] == 'B' || + Memc[str2] == 'b')) + epoch = sl_eb2d (epoch) + else if (epoch > 3000.0d0) + epoch = epoch - 2400000.5d0 + else + epoch = sl_ej2d (epoch) + } + } + } + + # Decode the ecliptic coordinate system. + case CTYPE_ECLIPTIC: + if (Memc[str1] == 'J' || Memc[str1] == 'j' || + Memc[str1] == 'B' || Memc[str1] == 'b') + ip = 2 + else + ip = 1 + if (ctod (Memc[str1], ip, epoch) <= 0) { + epoch = INDEFD + } else if (epoch <= 3000.0d0) { + if (Memc[str1] == 'B' || Memc[str1] == 'b') + epoch = sl_eb2d (epoch) + else if (Memc[str1] == 'J' || Memc[str1] == 'j') + epoch = sl_ej2d (epoch) + else if (epoch < 1984.0d0) + epoch = sl_eb2d (epoch) + else + epoch = sl_ej2d (epoch) + } else { + epoch = epoch - 2400000.5d0 + } + + # Decode the galactic and supergalactic coordinate system. + case CTYPE_GALACTIC, CTYPE_SUPERGALACTIC: + if (Memc[str1] == 'J' || Memc[str1] == 'j' || + Memc[str1] == 'B' || Memc[str1] == 'b') + ip = 2 + else + ip = 1 + if (ctod (Memc[str1], ip, epoch) <= 0) { + epoch = sl_eb2d (1950.0d0) + } else if (epoch <= 3000.0d0) { + if (Memc[str1] == 'J' || Memc[str1] == 'j') + epoch = sl_ej2d (epoch) + else if (Memc[str1] == 'B' || Memc[str1] == 'b') + epoch = sl_eb2d (epoch) + else if (epoch < 1984.0d0) + epoch = sl_eb2d (epoch) + else + epoch = sl_ej2d (epoch) + } else { + epoch = epoch - 2400000.5d0 + } + } + + # Return the appropriate error status. + if (ctype == 0) + stat = ERR + else if (ctype == CTYPE_EQUATORIAL && (radecsys == 0 || + IS_INDEFD(equinox) || IS_INDEFD(epoch))) + stat = ERR + else if (ctype == CTYPE_ECLIPTIC && IS_INDEFD(epoch)) + stat = ERR + else + stat = OK + + call sfree (sp) + + return (stat) +end + + +# SK_IMWCS -- Decode the sky coordinate system of the image. Return +# an error if the sky coordinate system is not one of the supported types +# or required information is missing from the image header. + +int procedure sk_imwcs (im, mw, ctype, lngax, latax, wtype, radecsys, + equinox, epoch) + +pointer im #I the image pointer +pointer mw #I pointer to the world coordinate system +int ctype #O the output coordinate type +int lngax #O the output ra/glon/elon axis +int latax #O the output dec/glat/elat axis +int wtype #O the output projection type +int radecsys #O the output equatorial reference system +double equinox #O the output equinox +double epoch #O the output epoch of the observation + +int i, ndim, axtype, day, month, year, ier, oldfits +pointer sp, atval +double hours +double imgetd(), sl_eb2d(), sl_ej2d() +int mw_stati(), strdic(), dtm_decode() +errchk mw_gwattrs(), imgstr(), imgetd() + +begin + call smark (sp) + call salloc (atval, SZ_LINE, TY_CHAR) + + # Initialize + ctype = 0 + lngax = 0 + latax = 0 + wtype = 0 + radecsys = 0 + equinox = INDEFD + epoch = INDEFD + + # Determine the sky coordinate system of the image. + ndim = mw_stati (mw, MW_NPHYSDIM) + do i = 1, ndim { + iferr (call mw_gwattrs (mw, i, "axtype", Memc[atval], SZ_LINE)) + call strcpy ("INDEF", Memc[atval], SZ_LINE) + axtype = strdic (Memc[atval], Memc[atval], SZ_LINE, AXTYPE_LIST) + switch (axtype) { + case AXTYPE_RA, AXTYPE_DEC: + ctype = CTYPE_EQUATORIAL + case AXTYPE_ELON, AXTYPE_ELAT: + ctype = CTYPE_ECLIPTIC + case AXTYPE_GLON, AXTYPE_GLAT: + ctype = CTYPE_GALACTIC + case AXTYPE_SLON, AXTYPE_SLAT: + ctype = CTYPE_SUPERGALACTIC + default: + ; + } + switch (axtype) { + case AXTYPE_RA, AXTYPE_ELON, AXTYPE_GLON, AXTYPE_SLON: + lngax = i + case AXTYPE_DEC, AXTYPE_ELAT, AXTYPE_GLAT, AXTYPE_SLAT: + latax = i + default: + ; + } + } + + # Return if the sky coordinate system cannot be decoded. + if (ctype == 0 || lngax == 0 || latax == 0) { + call sfree (sp) + return (ERR) + } + + # Decode the sky projection. + iferr { + call mw_gwattrs (mw, lngax, "wtype", Memc[atval], SZ_LINE) + } then { + iferr (call mw_gwattrs(mw, latax, "wtype", Memc[atval], SZ_LINE)) + call strcpy ("linear", Memc[atval], SZ_LINE) + } + wtype = strdic (Memc[atval], Memc[atval], SZ_LINE, WTYPE_LIST) + + # Return if the sky projection system is not supported. + if (wtype == 0) { + call sfree (sp) + return (ERR) + } + + # Determine the RA/DEC system and equinox. + if (ctype == CTYPE_EQUATORIAL) { + + # Get the equinox of the coordinate system. The EQUINOX keyword + # takes precedence over EPOCH. + iferr { + equinox = imgetd (im, "EQUINOX") + } then { + iferr { + equinox = imgetd (im, "EPOCH") + } then { + equinox = INDEFD + } + } + + # Determine which equatorial system will be used. The default + # is FK4 if equinox < 1984.0, FK5 if equinox is >= 1984. + iferr { + call imgstr (im, "RADECSYS", Memc[atval], SZ_LINE) + } then { + radecsys = 0 + } else { + call strlwr (Memc[atval]) + radecsys = strdic (Memc[atval], Memc[atval], SZ_LINE, + EQTYPE_LIST) + } + if (radecsys == 0) { + if (IS_INDEFD(equinox)) + radecsys = EQTYPE_FK5 + else if (equinox < 1984.0d0) + radecsys = EQTYPE_FK4 + else + radecsys = EQTYPE_FK5 + } + + # Get the MJD of the observation. If there is no MJD in the + # header use the DATE_OBS keyword value and transform it to + # an MJD. + iferr { + epoch = imgetd (im, "MJD-WCS") + } then { + iferr { + epoch = imgetd (im, "MJD-OBS") + } then { + iferr { + call imgstr (im, "DATE-OBS", Memc[atval], SZ_LINE) + } then { + epoch = INDEFD + } else if (dtm_decode (Memc[atval], year, month, day, + hours, oldfits) == OK) { + call sl_cadj (year, month, day, epoch, ier) + if (ier != 0) + epoch = INDEFD + else if (! IS_INDEFD(hours) && hours >= 0.0d0 && + hours <= 24.0d0) + epoch = epoch + hours / 24.0d0 + } else + epoch = INDEFD + } + } + + # Set the default equinox and epoch appropriate for each + # equatorial system if these are undefined. + switch (radecsys) { + case EQTYPE_FK4, EQTYPE_FK4NOE: + if (IS_INDEFD(equinox)) + equinox = 1950.0d0 + if (IS_INDEFD(epoch)) + epoch = sl_eb2d (1950.0d0) + case EQTYPE_FK5, EQTYPE_ICRS: + if (IS_INDEFD(equinox)) + equinox = 2000.0d0 + if (IS_INDEFD(epoch)) + epoch = sl_ej2d (2000.0d0) + case EQTYPE_GAPPT: + equinox = 2000.0d0 + ; + } + + # Return if the epoch is undefined. This can only occur if + # the equatorial coordinate system is GAPPT and there is NO + # epoch of observation in the image header. + if (IS_INDEFD(epoch)) { + call sfree (sp) + return (ERR) + } + } + + # Get the MJD of the observation. If there is no MJD in the + # header use the DATE_OBS keyword value and transform it to + # an MJD. + if (ctype == CTYPE_ECLIPTIC) { + + iferr { + epoch = imgetd (im, "MJD-WCS") + } then { + iferr { + epoch = imgetd (im, "MJD-OBS") + } then { + iferr { + call imgstr (im, "DATE-OBS", Memc[atval], SZ_LINE) + } then { + epoch = INDEFD + } else if (dtm_decode (Memc[atval], year, month, day, + hours, oldfits) == OK) { + call sl_cadj (year, month, day, epoch, ier) + if (ier != 0) + epoch = INDEFD + else if (! IS_INDEFD(hours) && hours >= 0.0d0 && + hours <= 24.0d0) + epoch = epoch + hours / 24.0d0 + } else + epoch = INDEFD + } + } + + # Return if the epoch is undefined. + if (IS_INDEFD(epoch)) { + call sfree (sp) + return (ERR) + } + } + + if (ctype == CTYPE_GALACTIC || ctype == CTYPE_SUPERGALACTIC) { + + # Get the MJD of the observation. If there is no MJD in the + # header use the DATE_OBS keyword value and transform it to + # an MJD. + iferr { + epoch = imgetd (im, "MJD-WCS") + } then { + iferr { + epoch = imgetd (im, "MJD-OBS") + } then { + iferr { + call imgstr (im, "DATE-OBS", Memc[atval], SZ_LINE) + } then { + epoch = sl_eb2d (1950.0d0) + } else if (dtm_decode (Memc[atval], year, month, day, + hours, oldfits) == OK) { + call sl_cadj (year, month, day, epoch, ier) + if (ier != 0) + epoch = sl_eb2d (1950.0d0) + else { + if (! IS_INDEFD(hours) && hours >= 0.0d0 && + hours <= 24.0d0) + epoch = epoch + hours / 24.0d0 + #if (epoch < 1984.0d0) + #epoch = sl_eb2d (epoch) + #else + #epoch = sl_ej2d (epoch) + } + } else + epoch = sl_eb2d (1950.0d0) + } + } + } + + call sfree (sp) + + return (OK) +end + + +# SK_ENWCS -- Encode the celestial wcs system. + +procedure sk_enwcs (coo, wcsstr, maxch) + +pointer coo #I the celestial coordinate system descriptor +char wcsstr[ARB] #O the output wcs string +int maxch #I the size of the output string + +double sk_statd(), sl_epj(), sl_epb() +int sk_stati() + +begin + switch (sk_stati (coo, S_CTYPE)) { + + case CTYPE_EQUATORIAL: + + switch (sk_stati(coo, S_RADECSYS)) { + + case EQTYPE_GAPPT: + if (IS_INDEFD(sk_statd(coo, S_EPOCH))) { + call sprintf (wcsstr, maxch, "apparent") + } else { + call sprintf (wcsstr, maxch, "apparent J%0.8f") + call pargd (sl_epj(sk_statd(coo, S_EPOCH))) + } + + case EQTYPE_FK5: + call sprintf (wcsstr, maxch, "fk5 J%0.3f J%0.8f") + call pargd (sk_statd(coo, S_EQUINOX)) + call pargd (sl_epj(sk_statd(coo, S_EPOCH))) + + case EQTYPE_ICRS: + call sprintf (wcsstr, maxch, "icrs J%0.3f J%0.8f") + call pargd (sk_statd(coo, S_EQUINOX)) + call pargd (sl_epj(sk_statd(coo, S_EPOCH))) + + case EQTYPE_FK4: + call sprintf (wcsstr, maxch, "fk4 B%0.3f B%0.8f") + call pargd (sk_statd(coo, S_EQUINOX)) + call pargd (sl_epb(sk_statd(coo, S_EPOCH))) + + case EQTYPE_FK4NOE: + call sprintf (wcsstr, maxch, "fk4noe B%0.3f B%0.8f") + call pargd (sk_statd(coo, S_EQUINOX)) + call pargd (sl_epb(sk_statd(coo, S_EPOCH))) + + default: + wcsstr[1] = EOS + } + + case CTYPE_ECLIPTIC: + if (IS_INDEFD(sk_statd(coo, S_EPOCH))) { + call sprintf (wcsstr, maxch, "ecliptic") + } else { + call sprintf (wcsstr, maxch, "ecliptic J%0.8f") + call pargd (sl_epj(sk_statd(coo, S_EPOCH))) + } + + case CTYPE_GALACTIC: + call sprintf (wcsstr, maxch, "galactic J%0.8f") + call pargd (sl_epj(sk_statd(coo, S_EPOCH))) + + case CTYPE_SUPERGALACTIC: + call sprintf (wcsstr, maxch, "supergalactic j%0.8f") + call pargd (sl_epj(sk_statd(coo, S_EPOCH))) + } +end + + +# SK_COPY -- Copy the coodinate structure. + +pointer procedure sk_copy (cooin) + +pointer cooin #I the pointer to the input structure + +pointer cooout + +begin + if (cooin == NULL) + cooout = NULL + else { + call calloc (cooout, LEN_SKYCOOSTRUCT, TY_STRUCT) + SKY_VXOFF(cooout) = SKY_VXOFF(cooin) + SKY_VYOFF(cooout) = SKY_VYOFF(cooin) + SKY_VXSTEP(cooout) = SKY_VXSTEP(cooin) + SKY_VYSTEP(cooout) = SKY_VYSTEP(cooin) + SKY_EQUINOX(cooout) = SKY_EQUINOX(cooin) + SKY_EPOCH(cooout) = SKY_EPOCH(cooin) + SKY_CTYPE(cooout) = SKY_CTYPE(cooin) + SKY_RADECSYS(cooout) = SKY_RADECSYS(cooin) + SKY_WTYPE(cooout) = SKY_WTYPE(cooin) + SKY_PLNGAX(cooout) = SKY_PLNGAX(cooin) + SKY_PLATAX(cooout) = SKY_PLATAX(cooin) + SKY_XLAX(cooout) = SKY_XLAX(cooin) + SKY_YLAX(cooout) = SKY_YLAX(cooin) + SKY_PIXTYPE(cooout) = SKY_PIXTYPE(cooin) + SKY_NLNGAX(cooout) = SKY_NLNGAX(cooin) + SKY_NLATAX(cooout) = SKY_NLATAX(cooin) + SKY_NLNGUNITS(cooout) = SKY_NLNGUNITS(cooin) + SKY_NLATUNITS(cooout) = SKY_NLATUNITS(cooin) + call strcpy (SKY_COOSYSTEM(cooin), SKY_COOSYSTEM(cooout), + SZ_FNAME) + } + + return (cooout) +end + + +# SK_CLOSE -- Free the coordinate structure. + +procedure sk_close (coo) + +pointer coo #U the input coordinate structure + +begin + if (coo != NULL) + call mfree (coo, TY_STRUCT) +end diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/sksaveim.f b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/sksaveim.f new file mode 100644 index 00000000..63e39d30 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/sksaveim.f @@ -0,0 +1,363 @@ + subroutine sksavm (coo, mw, im) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer coo + integer mw + integer im + logical xerpop + logical xerflg + common /xercom/ xerflg + integer sw0001,sw0002 + integer*2 st0001(7) + integer*2 st0002(3) + integer*2 st0003(7) + integer*2 st0004(4) + integer*2 st0005(9) + integer*2 st0006(4) + integer*2 st0007(8) + integer*2 st0008(8) + integer*2 st0009(9) + integer*2 st0010(7) + integer*2 st0011(8) + integer*2 st0012(8) + integer*2 st0013(9) + integer*2 st0014(4) + integer*2 st0015(8) + integer*2 st0016(8) + integer*2 st0017(9) + integer*2 st0018(5) + integer*2 st0019(8) + integer*2 st0020(8) + integer*2 st0021(9) + integer*2 st0022(6) + integer*2 st0023(8) + integer*2 st0024(8) + integer*2 st0025(7) + integer*2 st0026(5) + integer*2 st0027(7) + integer*2 st0028(5) + integer*2 st0029(9) + integer*2 st0030(8) + integer*2 st0031(8) + integer*2 st0032(7) + integer*2 st0033(5) + integer*2 st0034(7) + integer*2 st0035(5) + integer*2 st0036(9) + integer*2 st0037(8) + integer*2 st0038(8) + integer*2 st0039(7) + integer*2 st0040(5) + integer*2 st0041(7) + integer*2 st0042(5) + integer*2 st0043(9) + integer*2 st0044(8) + integer*2 st0045(8) + save + integer iyy + data st0001 / 97,120,116,121,112,101, 0/ + data st0002 /114, 97, 0/ + data st0003 / 97,120,116,121,112,101, 0/ + data st0004 /100,101, 99, 0/ + data (st0005(iyy),iyy= 1, 8) /114, 97,100,101, 99,115,121,115/ + data (st0005(iyy),iyy= 9, 9) / 0/ + data st0006 / 70, 75, 52, 0/ + data st0007 /101,113,117,105,110,111,120, 0/ + data st0008 /109,106,100, 45,119, 99,115, 0/ + data (st0009(iyy),iyy= 1, 8) /114, 97,100,101, 99,115,121,115/ + data (st0009(iyy),iyy= 9, 9) / 0/ + data st0010 / 70, 75, 52, 78, 79, 69, 0/ + data st0011 /101,113,117,105,110,111,120, 0/ + data st0012 /109,106,100, 45,119, 99,115, 0/ + data (st0013(iyy),iyy= 1, 8) /114, 97,100,101, 99,115,121,115/ + data (st0013(iyy),iyy= 9, 9) / 0/ + data st0014 / 70, 75, 53, 0/ + data st0015 /101,113,117,105,110,111,120, 0/ + data st0016 /109,106,100, 45,119, 99,115, 0/ + data (st0017(iyy),iyy= 1, 8) /114, 97,100,101, 99,115,121,115/ + data (st0017(iyy),iyy= 9, 9) / 0/ + data st0018 / 73, 67, 82, 83, 0/ + data st0019 /101,113,117,105,110,111,120, 0/ + data st0020 /109,106,100, 45,119, 99,115, 0/ + data (st0021(iyy),iyy= 1, 8) /114, 97,100,101, 99,115,121,115/ + data (st0021(iyy),iyy= 9, 9) / 0/ + data st0022 / 71, 65, 80, 80, 84, 0/ + data st0023 /101,113,117,105,110,111,120, 0/ + data st0024 /109,106,100, 45,119, 99,115, 0/ + data st0025 / 97,120,116,121,112,101, 0/ + data st0026 /101,108,111,110, 0/ + data st0027 / 97,120,116,121,112,101, 0/ + data st0028 /101,108, 97,116, 0/ + data (st0029(iyy),iyy= 1, 8) /114, 97,100,101, 99,115,121,115/ + data (st0029(iyy),iyy= 9, 9) / 0/ + data st0030 /101,113,117,105,110,111,120, 0/ + data st0031 /109,106,100, 45,119, 99,115, 0/ + data st0032 / 97,120,116,121,112,101, 0/ + data st0033 /103,108,111,110, 0/ + data st0034 / 97,120,116,121,112,101, 0/ + data st0035 /103,108, 97,116, 0/ + data (st0036(iyy),iyy= 1, 8) /114, 97,100,101, 99,115,121,115/ + data (st0036(iyy),iyy= 9, 9) / 0/ + data st0037 /101,113,117,105,110,111,120, 0/ + data st0038 /109,106,100, 45,119, 99,115, 0/ + data st0039 / 97,120,116,121,112,101, 0/ + data st0040 /115,108,111,110, 0/ + data st0041 / 97,120,116,121,112,101, 0/ + data st0042 /115,108, 97,116, 0/ + data (st0043(iyy),iyy= 1, 8) /114, 97,100,101, 99,115,121,115/ + data (st0043(iyy),iyy= 9, 9) / 0/ + data st0044 /101,113,117,105,110,111,120, 0/ + data st0045 /109,106,100, 45,119, 99,115, 0/ + sw0001=(memi(coo+12) ) + goto 110 +120 continue + call mwswas (mw, memi(coo+15) , st0001, st0002) + call mwswas (mw, memi(coo+16) , st0003, st0004) + sw0002=(memi(coo+13) ) + goto 130 +140 continue + call imastr (im, st0005, st0006) + call imaddd (im, st0007, memd((((coo+8)-1)/2+1)) ) + call imaddd (im, st0008, memd((((coo+10)-1)/2+1)) ) + goto 131 +150 continue + call imastr (im, st0009, st0010) + call imaddd (im, st0011, memd((((coo+8)-1)/2+1)) ) + call imaddd (im, st0012, memd((((coo+10)-1)/2+1)) ) + goto 131 +160 continue + call imastr (im, st0013, st0014) + call imaddd (im, st0015, memd((((coo+8)-1)/2+1)) ) + call xerpsh + call imdelf (im, st0016) + if (.not.xerpop()) goto 170 +170 continue + goto 131 +180 continue + call imastr (im, st0017, st0018) + call imaddd (im, st0019, memd((((coo+8)-1)/2+1)) ) + call xerpsh + call imdelf (im, st0020) + if (.not.xerpop()) goto 190 +190 continue + goto 131 +200 continue + call imastr (im, st0021, st0022) + call xerpsh + call imdelf (im, st0023) + if (.not.xerpop()) goto 210 +210 continue + call imaddd (im, st0024, memd((((coo+10)-1)/2+1)) ) + goto 131 +130 continue + if (sw0002.lt.1.or.sw0002.gt.5) goto 131 + goto (140,150,160,180,200),sw0002 +131 continue + goto 111 +220 continue + call mwswas (mw, memi(coo+15) , st0025, st0026) + call mwswas (mw, memi(coo+16) , st0027, st0028) + call xerpsh + call imdelf (im, st0029) + if (.not.xerpop()) goto 230 +230 continue + call xerpsh + call imdelf (im, st0030) + if (.not.xerpop()) goto 240 +240 continue + call imaddd (im, st0031, memd((((coo+10)-1)/2+1)) ) + goto 111 +250 continue + call mwswas (mw, memi(coo+15) , st0032, st0033) + call mwswas (mw, memi(coo+16) , st0034, st0035) + call xerpsh + call imdelf (im, st0036) + if (.not.xerpop()) goto 260 +260 continue + call xerpsh + call imdelf (im, st0037) + if (.not.xerpop()) goto 270 +270 continue + call xerpsh + call imdelf (im, st0038) + if (.not.xerpop()) goto 280 +280 continue + goto 111 +290 continue + call mwswas (mw, memi(coo+15) , st0039, st0040) + call mwswas (mw, memi(coo+16) , st0041, st0042) + call xerpsh + call imdelf (im, st0043) + if (.not.xerpop()) goto 300 +300 continue + call xerpsh + call imdelf (im, st0044) + if (.not.xerpop()) goto 310 +310 continue + call xerpsh + call imdelf (im, st0045) + if (.not.xerpop()) goto 320 +320 continue + goto 111 +110 continue + if (sw0001.lt.1.or.sw0001.gt.4) goto 111 + goto (120,220,250,290),sw0001 +111 continue +100 return + end + subroutine skctym (coo, im) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer coo + integer im + integer sp + integer wtype + integer key1 + integer key2 + integer attr + integer skwrdr + integer sw0001 + integer*2 st0001(8) + integer*2 st0002(8) + integer*2 st0003(7) + integer*2 st0004(7) + integer*2 st0005(114) + integer*2 st0006(4) + integer*2 st0007(9) + integer*2 st0008(9) + integer*2 st0009(9) + integer*2 st0010(9) + integer*2 st0011(9) + integer*2 st0012(9) + integer*2 st0013(9) + integer*2 st0014(9) + integer*2 st0015(7) + integer*2 st0016(7) + save + integer iyy + data st0001 / 67, 84, 89, 80, 69, 37,100, 0/ + data st0002 / 67, 84, 89, 80, 69, 37,100, 0/ + data st0003 / 76, 73, 78, 69, 65, 82, 0/ + data st0004 / 76, 73, 78, 69, 65, 82, 0/ + data (st0005(iyy),iyy= 1, 8) /124,108,105,110,124, 97,122,112/ + data (st0005(iyy),iyy= 9,16) /124,116, 97,110,124,115,105,110/ + data (st0005(iyy),iyy=17,24) /124,115,116,103,124, 97,114, 99/ + data (st0005(iyy),iyy=25,32) /124,122,112,110,124,122,101, 97/ + data (st0005(iyy),iyy=33,40) /124, 97,105,114,124, 99,121,112/ + data (st0005(iyy),iyy=41,48) /124, 99, 97,114,124,109,101,114/ + data (st0005(iyy),iyy=49,56) /124, 99,101, 97,124, 99,111,112/ + data (st0005(iyy),iyy=57,64) /124, 99,111,100,124, 99,111,101/ + data (st0005(iyy),iyy=65,72) /124, 99,111,111,124, 98,111,110/ + data (st0005(iyy),iyy=73,80) /124,112, 99,111,124,103,108,115/ + data (st0005(iyy),iyy=81,88) /124,112, 97,114,124, 97,105,116/ + data (st0005(iyy),iyy=89,96) /124,109,111,108,124, 99,115, 99/ + data (st0005(iyy),iyy=97,104) /124,113,115, 99,124,116,115, 99/ + data (st0005(iyy),iyy=105,112) /124,116,110,120,124,122,112,120/ + data (st0005(iyy),iyy=113,114) /124, 0/ + data st0006 /116, 97,110, 0/ + data (st0007(iyy),iyy= 1, 8) / 82, 65, 45, 45, 45, 37, 51,115/ + data (st0007(iyy),iyy= 9, 9) / 0/ + data (st0008(iyy),iyy= 1, 8) / 68, 69, 67, 45, 45, 37, 51,115/ + data (st0008(iyy),iyy= 9, 9) / 0/ + data (st0009(iyy),iyy= 1, 8) / 69, 76, 79, 78, 45, 37, 51,115/ + data (st0009(iyy),iyy= 9, 9) / 0/ + data (st0010(iyy),iyy= 1, 8) / 69, 76, 65, 84, 45, 37, 51,115/ + data (st0010(iyy),iyy= 9, 9) / 0/ + data (st0011(iyy),iyy= 1, 8) / 71, 76, 79, 78, 45, 37, 51,115/ + data (st0011(iyy),iyy= 9, 9) / 0/ + data (st0012(iyy),iyy= 1, 8) / 71, 76, 65, 84, 45, 37, 51,115/ + data (st0012(iyy),iyy= 9, 9) / 0/ + data (st0013(iyy),iyy= 1, 8) / 83, 76, 79, 78, 45, 37, 51,115/ + data (st0013(iyy),iyy= 9, 9) / 0/ + data (st0014(iyy),iyy= 1, 8) / 83, 76, 65, 84, 45, 37, 51,115/ + data (st0014(iyy),iyy= 9, 9) / 0/ + data st0015 / 76, 73, 78, 69, 65, 82, 0/ + data st0016 / 76, 73, 78, 69, 65, 82, 0/ + call smark (sp) + call salloc (key1, 8, 2) + call salloc (key2, 8, 2) + call salloc (wtype, 3, 2) + call salloc (attr, 8, 2) + call sprinf (memc(key1), 8, st0001) + call pargi (memi(coo+15) ) + call sprinf (memc(key2), 8, st0002) + call pargi (memi(coo+16) ) + if (.not.(memi(coo+14) .le. 0 .or. memi(coo+14) .eq. 1)) goto + * 110 + call imastr (im, memc(key1), st0003) + call imastr (im, memc(key2), st0004) + call sfree (sp) + goto 100 +110 continue + if (.not.(skwrdr (memi(coo+14) , memc(wtype), 3, st0005) .le. 0 + * )) goto 120 + call xstrcy(st0006, memc(wtype), 3) +120 continue + call strupr (memc(wtype)) + sw0001=(memi(coo+12) ) + goto 130 +140 continue + call sprinf (memc(attr), 8, st0007) + call pargsr (memc(wtype)) + call imastr (im, memc(key1), memc(attr)) + call sprinf (memc(attr), 8, st0008) + call pargsr (memc(wtype)) + call imastr (im, memc(key2), memc(attr)) + goto 131 +150 continue + call sprinf (memc(attr), 8, st0009) + call pargsr (memc(wtype)) + call imastr (im, memc(key1), memc(attr)) + call sprinf (memc(attr), 8, st0010) + call pargsr (memc(wtype)) + call imastr (im, memc(key2), memc(attr)) + goto 131 +160 continue + call sprinf (memc(attr), 8, st0011) + call pargsr (memc(wtype)) + call imastr (im, memc(key1), memc(attr)) + call sprinf (memc(attr), 8, st0012) + call pargsr (memc(wtype)) + call imastr (im, memc(key2), memc(attr)) + goto 131 +170 continue + call sprinf (memc(attr), 8, st0013) + call pargsr (memc(wtype)) + call imastr (im, memc(key1), memc(attr)) + call sprinf (memc(attr), 8, st0014) + call pargsr (memc(wtype)) + call imastr (im, memc(key2), memc(attr)) + goto 131 +180 continue + call imastr (im, memc(key1), st0015) + call imastr (im, memc(key2), st0016) + goto 131 +130 continue + if (sw0001.lt.1.or.sw0001.gt.4) goto 180 + goto (140,150,160,170),sw0001 +131 continue + call sfree (sp) +100 return + end +c sprinf sprintf +c skctym sk_ctypeim +c skwrdr sk_wrdstr +c sksavm sk_saveim +c mwswas mw_swattrs +c pargsr pargstr diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/sksaveim.x b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/sksaveim.x new file mode 100644 index 00000000..77b5a1d9 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/sksaveim.x @@ -0,0 +1,157 @@ +include "skywcsdef.h" +include "skywcs.h" + +# SK_SAVEIM -- Update the image header keywords that describe the +# fundamental coordinate system, CTYPE, RADECSYS, EQUINOX (EPOCH), and +# MJD-WCS. + +procedure sk_saveim (coo, mw, im) + +pointer coo #I pointer to the coordinate structure +pointer mw #I pointer to the mwcs structure +pointer im #I image descriptor + +errchk imdelf() + +begin + # Move all this to a separate routine + switch (SKY_CTYPE(coo)) { + + case CTYPE_EQUATORIAL: + call mw_swattrs (mw, SKY_PLNGAX(coo), "axtype", "ra") + call mw_swattrs (mw, SKY_PLATAX(coo), "axtype", "dec") + switch (SKY_RADECSYS(coo)) { + case EQTYPE_FK4: + call imastr (im, "radecsys", "FK4") + call imaddd (im, "equinox", SKY_EQUINOX(coo)) + call imaddd (im, "mjd-wcs", SKY_EPOCH(coo)) + case EQTYPE_FK4NOE: + call imastr (im, "radecsys", "FK4NOE") + call imaddd (im, "equinox", SKY_EQUINOX(coo)) + call imaddd (im, "mjd-wcs", SKY_EPOCH(coo)) + case EQTYPE_FK5: + call imastr (im, "radecsys", "FK5") + call imaddd (im, "equinox", SKY_EQUINOX(coo)) + iferr (call imdelf (im, "mjd-wcs")) + ; + case EQTYPE_ICRS: + call imastr (im, "radecsys", "ICRS") + call imaddd (im, "equinox", SKY_EQUINOX(coo)) + iferr (call imdelf (im, "mjd-wcs")) + ; + case EQTYPE_GAPPT: + call imastr (im, "radecsys", "GAPPT") + iferr (call imdelf (im, "equinox")) + ; + call imaddd (im, "mjd-wcs", SKY_EPOCH(coo)) + } + + case CTYPE_ECLIPTIC: + call mw_swattrs (mw, SKY_PLNGAX(coo), "axtype", "elon") + call mw_swattrs (mw, SKY_PLATAX(coo), "axtype", "elat") + iferr (call imdelf (im, "radecsys")) + ; + iferr (call imdelf (im, "equinox")) + ; + call imaddd (im, "mjd-wcs", SKY_EPOCH(coo)) + + case CTYPE_GALACTIC: + call mw_swattrs (mw, SKY_PLNGAX(coo), "axtype", "glon") + call mw_swattrs (mw, SKY_PLATAX(coo), "axtype", "glat") + iferr (call imdelf (im, "radecsys")) + ; + iferr (call imdelf (im, "equinox")) + ; + iferr (call imdelf (im, "mjd-wcs")) + ; + + case CTYPE_SUPERGALACTIC: + call mw_swattrs (mw, SKY_PLNGAX(coo), "axtype", "slon") + call mw_swattrs (mw, SKY_PLATAX(coo), "axtype", "slat") + iferr (call imdelf (im, "radecsys")) + ; + iferr (call imdelf (im, "equinox")) + ; + iferr (call imdelf (im, "mjd-wcs")) + ; + } +end + + +# SK_CTYPEIM -- Modify the CTYPE keywords appropriately. This step will +# become unnecessary when MWCS is updated to deal with non-equatorial celestial +# coordinate systems. + +procedure sk_ctypeim (coo, im) + +pointer coo #I pointer to the coordinate structure +pointer im #I image descriptor + +pointer sp, wtype, key1, key2, attr +int sk_wrdstr() + +begin + call smark (sp) + call salloc (key1, 8, TY_CHAR) + call salloc (key2, 8, TY_CHAR) + call salloc (wtype, 3, TY_CHAR) + call salloc (attr, 8, TY_CHAR) + + call sprintf (Memc[key1], 8, "CTYPE%d") + call pargi (SKY_PLNGAX(coo)) + call sprintf (Memc[key2], 8, "CTYPE%d") + call pargi (SKY_PLATAX(coo)) + + if (SKY_WTYPE(coo) <= 0 || SKY_WTYPE(coo) == WTYPE_LIN) { + call imastr (im, Memc[key1], "LINEAR") + call imastr (im, Memc[key2], "LINEAR") + call sfree (sp) + return + } + + if (sk_wrdstr (SKY_WTYPE(coo), Memc[wtype], 3, WTYPE_LIST) <= 0) + call strcpy ("tan", Memc[wtype], 3) + call strupr (Memc[wtype]) + + # Move all this to a separate routine + switch (SKY_CTYPE(coo)) { + + case CTYPE_EQUATORIAL: + call sprintf (Memc[attr], 8, "RA---%3s") + call pargstr (Memc[wtype]) + call imastr (im, Memc[key1], Memc[attr]) + call sprintf (Memc[attr], 8, "DEC--%3s") + call pargstr (Memc[wtype]) + call imastr (im, Memc[key2], Memc[attr]) + + case CTYPE_ECLIPTIC: + call sprintf (Memc[attr], 8, "ELON-%3s") + call pargstr (Memc[wtype]) + call imastr (im, Memc[key1], Memc[attr]) + call sprintf (Memc[attr], 8, "ELAT-%3s") + call pargstr (Memc[wtype]) + call imastr (im, Memc[key2], Memc[attr]) + + case CTYPE_GALACTIC: + call sprintf (Memc[attr], 8, "GLON-%3s") + call pargstr (Memc[wtype]) + call imastr (im, Memc[key1], Memc[attr]) + call sprintf (Memc[attr], 8, "GLAT-%3s") + call pargstr (Memc[wtype]) + call imastr (im, Memc[key2], Memc[attr]) + + case CTYPE_SUPERGALACTIC: + call sprintf (Memc[attr], 8, "SLON-%3s") + call pargstr (Memc[wtype]) + call imastr (im, Memc[key1], Memc[attr]) + call sprintf (Memc[attr], 8, "SLAT-%3s") + call pargstr (Memc[wtype]) + call imastr (im, Memc[key2], Memc[attr]) + + default: + call imastr (im, Memc[key1], "LINEAR") + call imastr (im, Memc[key2], "LINEAR") + } + + call sfree (sp) +end diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skset.f b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skset.f new file mode 100644 index 00000000..65765222 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skset.f @@ -0,0 +1,179 @@ + subroutine sksetd (coo, param, value) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer coo + integer param + double precision value + logical xerflg + common /xercom/ xerflg + integer sw0001 + integer*2 st0001(46) + save + integer iyy + data (st0001(iyy),iyy= 1, 8) / 83, 75, 89, 95, 83, 69, 84, 68/ + data (st0001(iyy),iyy= 9,16) / 58, 32, 85,110,107,110,111,119/ + data (st0001(iyy),iyy=17,24) /110, 32, 99,111,111,114,100,105/ + data (st0001(iyy),iyy=25,32) /110, 97,116,101, 32,115,121,115/ + data (st0001(iyy),iyy=33,40) /116,101,109, 32,112, 97,114, 97/ + data (st0001(iyy),iyy=41,46) /109,101,116,101,114, 0/ + sw0001=(param) + goto 110 +120 continue + memd((((coo)-1)/2+1)) = value + goto 111 +130 continue + memd((((coo+2)-1)/2+1)) = value + goto 111 +140 continue + memd((((coo+4)-1)/2+1)) = value + goto 111 +150 continue + memd((((coo+6)-1)/2+1)) = value + goto 111 +160 continue + memd((((coo+8)-1)/2+1)) = value + goto 111 +170 continue + memd((((coo+10)-1)/2+1)) = value + goto 111 +180 continue + call xerror(0, st0001) + if (xerflg) goto 100 + goto 111 +110 continue + if (sw0001.lt.1.or.sw0001.gt.6) goto 180 + goto (120,130,140,150,160,170),sw0001 +111 continue +100 return + end + subroutine skseti (coo, param, value) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer coo + integer param + integer value + logical xerflg + common /xercom/ xerflg + integer sw0001 + integer*2 st0001(46) + save + integer iyy + data (st0001(iyy),iyy= 1, 8) / 83, 75, 89, 95, 83, 69, 84, 73/ + data (st0001(iyy),iyy= 9,16) / 58, 32, 85,110,107,110,111,119/ + data (st0001(iyy),iyy=17,24) /110, 32, 99,111,111,114,100,105/ + data (st0001(iyy),iyy=25,32) /110, 97,116,101, 32,115,121,115/ + data (st0001(iyy),iyy=33,40) /116,101,109, 32,112, 97,114, 97/ + data (st0001(iyy),iyy=41,46) /109,101,116,101,114, 0/ + sw0001=(param) + goto 110 +120 continue + memi(coo+12) = value + goto 111 +130 continue + memi(coo+13) = value + goto 111 +140 continue + memi(coo+14) = value + goto 111 +150 continue + memi(coo+15) = value + goto 111 +160 continue + memi(coo+16) = value + goto 111 +170 continue + memi(coo+17) = value + goto 111 +180 continue + memi(coo+18) = value + goto 111 +190 continue + memi(coo+19) = value + goto 111 +200 continue + memi(coo+20) = value + goto 111 +210 continue + memi(coo+21) = value + goto 111 +220 continue + memi(coo+22) = value + goto 111 +230 continue + memi(coo+23) = value + goto 111 +240 continue + memi(coo+24) = value + goto 111 +250 continue + call xerror(0, st0001) + if (xerflg) goto 100 + goto 111 +110 continue + sw0001=sw0001-6 + if (sw0001.lt.1.or.sw0001.gt.14) goto 250 + goto (120,130,140,150,160,170,180,190,200,210,220,230,250, + * 240),sw0001 +111 continue +100 return + end + subroutine sksets (coo, param, value) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer coo + integer param + integer*2 value(*) + logical xerflg + common /xercom/ xerflg + integer sw0001 + integer*2 st0001(48) + save + integer iyy + data (st0001(iyy),iyy= 1, 8) / 83, 75, 89, 95, 83, 69, 84, 83/ + data (st0001(iyy),iyy= 9,16) / 84, 82, 58, 32, 85,110,107,110/ + data (st0001(iyy),iyy=17,24) /111,119,110, 32, 99,111,111,114/ + data (st0001(iyy),iyy=25,32) /100,105,110, 97,116,101, 32,115/ + data (st0001(iyy),iyy=33,40) /121,115,116,101,109, 32,112, 97/ + data (st0001(iyy),iyy=41,48) /114, 97,109,101,116,101,114, 0/ + sw0001=(param) + goto 110 +120 continue + call xstrcy(value, memc((((coo+25)-1)*2+1)) , 255 ) + goto 111 +130 continue + call xerror(0, st0001) + if (xerflg) goto 100 + goto 111 +110 continue + if (sw0001.eq.19) goto 120 + goto 130 +111 continue +100 return + end +c sksetd sk_setd +c skseti sk_seti +c sksets sk_sets diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skset.x b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skset.x new file mode 100644 index 00000000..9e7191c3 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skset.x @@ -0,0 +1,90 @@ +include "skywcsdef.h" +include "skywcs.h" + + +# SK_SETD -- Set a double precision coordinate parameter. + +procedure sk_setd (coo, param, value) + +pointer coo #I pointer to the coordinate structure +int param #I the input parameter +double value #I the parameter value + +begin + switch (param) { + case S_VXOFF: + SKY_VXOFF(coo) = value + case S_VYOFF: + SKY_VYOFF(coo) = value + case S_VXSTEP: + SKY_VXSTEP(coo) = value + case S_VYSTEP: + SKY_VYSTEP(coo) = value + case S_EQUINOX: + SKY_EQUINOX(coo) = value + case S_EPOCH: + SKY_EPOCH(coo) = value + default: + call error (0, "SKY_SETD: Unknown coordinate system parameter") + } +end + + +# SK_SETI -- Set an integer coordinate parameter. + +procedure sk_seti (coo, param, value) + +pointer coo #I pointer to the coordinate structure +int param #I the input parameter +int value #I the parameter value + +begin + switch (param) { + case S_CTYPE: + SKY_CTYPE(coo) = value + case S_RADECSYS: + SKY_RADECSYS(coo) = value + case S_WTYPE: + SKY_WTYPE(coo) = value + case S_PLNGAX: + SKY_PLNGAX(coo) = value + case S_PLATAX: + SKY_PLATAX(coo) = value + case S_XLAX: + SKY_XLAX(coo) = value + case S_YLAX: + SKY_YLAX(coo) = value + case S_PIXTYPE: + SKY_PIXTYPE(coo) = value + case S_NLNGAX: + SKY_NLNGAX(coo) = value + case S_NLATAX: + SKY_NLATAX(coo) = value + case S_NLNGUNITS: + SKY_NLNGUNITS(coo) = value + case S_NLATUNITS: + SKY_NLATUNITS(coo) = value + case S_STATUS: + SKY_STATUS(coo) = value + default: + call error (0, "SKY_SETI: Unknown coordinate system parameter") + } +end + + +# SK_SETS -- Set a character string coordinate parameter. + +procedure sk_sets (coo, param, value) + +pointer coo #I pointer to the coordinate structure +int param #I the input parameter +char value[ARB] #I the parameter value + +begin + switch (param) { + case S_COOSYSTEM: + call strcpy (value, SKY_COOSYSTEM(coo), SZ_FNAME) + default: + call error (0, "SKY_SETSTR: Unknown coordinate system parameter") + } +end diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skstat.f b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skstat.f new file mode 100644 index 00000000..4c3c8397 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skstat.f @@ -0,0 +1,179 @@ + double precision function skstad (coo, param) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer coo + integer param + logical xerflg + common /xercom/ xerflg + integer sw0001 + integer*2 st0001(47) + save + integer iyy + data (st0001(iyy),iyy= 1, 8) / 83, 75, 89, 95, 83, 84, 65, 84/ + data (st0001(iyy),iyy= 9,16) / 68, 58, 32, 85,110,107,110,111/ + data (st0001(iyy),iyy=17,24) /119,110, 32, 99,111,111,114,100/ + data (st0001(iyy),iyy=25,32) /105,110, 97,116,101, 32,115,121/ + data (st0001(iyy),iyy=33,40) /115,116,101,109, 32,112, 97,114/ + data (st0001(iyy),iyy=41,47) / 97,109,101,116,101,114, 0/ + skstad = 0 + sw0001=(param) + goto 110 +120 continue + skstad = (memd((((coo)-1)/2+1)) ) + goto 100 +130 continue + skstad = (memd((((coo+2)-1)/2+1)) ) + goto 100 +140 continue + skstad = (memd((((coo+4)-1)/2+1)) ) + goto 100 +150 continue + skstad = (memd((((coo+6)-1)/2+1)) ) + goto 100 +160 continue + skstad = (memd((((coo+8)-1)/2+1)) ) + goto 100 +170 continue + skstad = (memd((((coo+10)-1)/2+1)) ) + goto 100 +180 continue + call xerror(0, st0001) + if (xerflg) goto 100 + goto 111 +110 continue + if (sw0001.lt.1.or.sw0001.gt.6) goto 180 + goto (120,130,140,150,160,170),sw0001 +111 continue +100 return + end + integer function skstai (coo, param) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer coo + integer param + logical xerflg + common /xercom/ xerflg + integer sw0001 + integer*2 st0001(47) + save + integer iyy + data (st0001(iyy),iyy= 1, 8) / 83, 75, 89, 95, 83, 84, 65, 84/ + data (st0001(iyy),iyy= 9,16) / 73, 58, 32, 85,110,107,110,111/ + data (st0001(iyy),iyy=17,24) /119,110, 32, 99,111,111,114,100/ + data (st0001(iyy),iyy=25,32) /105,110, 97,116,101, 32,115,121/ + data (st0001(iyy),iyy=33,40) /115,116,101,109, 32,112, 97,114/ + data (st0001(iyy),iyy=41,47) / 97,109,101,116,101,114, 0/ + sw0001=(param) + goto 110 +120 continue + skstai = (memi(coo+12) ) + goto 100 +130 continue + skstai = (memi(coo+13) ) + goto 100 +140 continue + skstai = (memi(coo+14) ) + goto 100 +150 continue + skstai = (memi(coo+15) ) + goto 100 +160 continue + skstai = (memi(coo+16) ) + goto 100 +170 continue + skstai = (memi(coo+17) ) + goto 100 +180 continue + skstai = (memi(coo+18) ) + goto 100 +190 continue + skstai = (memi(coo+19) ) + goto 100 +200 continue + skstai = (memi(coo+20) ) + goto 100 +210 continue + skstai = (memi(coo+21) ) + goto 100 +220 continue + skstai = (memi(coo+22) ) + goto 100 +230 continue + skstai = (memi(coo+23) ) + goto 100 +240 continue + skstai = (memi(coo+24) ) + goto 100 +250 continue + call xerror(0, st0001) + if (xerflg) goto 100 + goto 111 +110 continue + sw0001=sw0001-6 + if (sw0001.lt.1.or.sw0001.gt.14) goto 250 + goto (120,130,140,150,160,170,180,190,200,210,220,230,250, + * 240),sw0001 +111 continue +100 return + end + subroutine skstas (coo, param, value, maxch) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer coo + integer param + integer*2 value + integer maxch + logical xerflg + common /xercom/ xerflg + integer sw0001 + integer*2 st0001(48) + save + integer iyy + data (st0001(iyy),iyy= 1, 8) / 83, 75, 89, 95, 71, 69, 84, 83/ + data (st0001(iyy),iyy= 9,16) / 84, 82, 58, 32, 85,110,107,110/ + data (st0001(iyy),iyy=17,24) /111,119,110, 32, 99,111,111,114/ + data (st0001(iyy),iyy=25,32) /100,105,110, 97,116,101, 32,115/ + data (st0001(iyy),iyy=33,40) /121,115,116,101,109, 32,112, 97/ + data (st0001(iyy),iyy=41,48) /114, 97,109,101,116,101,114, 0/ + sw0001=(param) + goto 110 +120 continue + call xstrcy(memc((((coo+25)-1)*2+1)) , value, maxch) + goto 111 +130 continue + call xerror(0, st0001) + if (xerflg) goto 100 + goto 111 +110 continue + if (sw0001.eq.19) goto 120 + goto 130 +111 continue +100 return + end +c skstad sk_statd +c skstai sk_stati +c skstas sk_stats diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skstat.x b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skstat.x new file mode 100644 index 00000000..82d2f1c2 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skstat.x @@ -0,0 +1,90 @@ +include "skywcsdef.h" +include "skywcs.h" + + +# SK_STATD -- Get a double precision coordinate parameter. + +double procedure sk_statd (coo, param) + +pointer coo #I pointer to the coordinate structure +int param #I the input parameter + +begin + switch (param) { + case S_VXOFF: + return (SKY_VXOFF(coo)) + case S_VYOFF: + return (SKY_VYOFF(coo)) + case S_VXSTEP: + return (SKY_VXSTEP(coo)) + case S_VYSTEP: + return (SKY_VYSTEP(coo)) + case S_EQUINOX: + return (SKY_EQUINOX(coo)) + case S_EPOCH: + return (SKY_EPOCH(coo)) + default: + call error (0, "SKY_STATD: Unknown coordinate system parameter") + } +end + + +# SK_STATI -- Get an integer coordinate parameter. + +int procedure sk_stati (coo, param) + +pointer coo #I pointer to the coordinate structure +int param #I the input parameter + +begin + switch (param) { + case S_CTYPE: + return (SKY_CTYPE(coo)) + case S_RADECSYS: + return (SKY_RADECSYS(coo)) + case S_WTYPE: + return (SKY_WTYPE(coo)) + case S_PLNGAX: + return (SKY_PLNGAX(coo)) + case S_PLATAX: + return (SKY_PLATAX(coo)) + case S_XLAX: + return (SKY_XLAX(coo)) + case S_YLAX: + return (SKY_YLAX(coo)) + case S_PIXTYPE: + return (SKY_PIXTYPE(coo)) + case S_NLNGAX: + return (SKY_NLNGAX(coo)) + case S_NLATAX: + return (SKY_NLATAX(coo)) + case S_NLNGUNITS: + return (SKY_NLNGUNITS(coo)) + case S_NLATUNITS: + return (SKY_NLATUNITS(coo)) + case S_STATUS: + return (SKY_STATUS(coo)) + default: + call error (0, "SKY_STATI: Unknown coordinate system parameter") + } +end + + + +# SK_STATS -- Get a character string coordinate parameter. + +procedure sk_stats (coo, param, value, maxch) + +pointer coo #I pointer to the coordinate structure +int param #I the input parameter +char value #O the output string +int maxch #I the maximum size of the string + +begin + switch (param) { + case S_COOSYSTEM: + call strcpy (SKY_COOSYSTEM(coo), value, maxch) + default: + call error (0, "SKY_GETSTR: Unknown coordinate system parameter") + } +end diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/sktransform.f b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/sktransform.f new file mode 100644 index 00000000..85aff7b1 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/sktransform.f @@ -0,0 +1,756 @@ + subroutine skultn (cooin, cooout, ilng, ilat, olng, olat, npts) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer cooin + integer cooout + integer npts + double precision ilng(*) + double precision ilat(*) + double precision olng(*) + double precision olat(*) + double precision tilng + double precision tilat + double precision tolng + double precision tolat + integer i + integer sw0001,sw0002,sw0003,sw0004 + save + do 110 i = 1, npts + sw0001=(memi(cooin+22) ) + goto 120 +130 continue + tilng = ((15.0d0 * ilng(i))/57.295779513082320877) + goto 121 +140 continue + tilng = ((ilng(i))/57.295779513082320877) + goto 121 +150 continue + tilng = ilng(i) + goto 121 +160 continue + tilng = ilng(i) + goto 121 +120 continue + if (sw0001.lt.1.or.sw0001.gt.3) goto 160 + goto (140,150,130),sw0001 +121 continue + sw0002=(memi(cooin+23) ) + goto 170 +180 continue + tilat = ((15.0d0 * ilat(i))/57.295779513082320877) + goto 171 +190 continue + tilat = ((ilat(i))/57.295779513082320877) + goto 171 +200 continue + tilat = ilat(i) + goto 171 +210 continue + tilat = ilat(i) + goto 171 +170 continue + if (sw0002.lt.1.or.sw0002.gt.3) goto 210 + goto (190,200,180),sw0002 +171 continue + call sklltn (cooin, cooout, tilng, tilat, 1.6d308, 1.6d308, + * 0.0d0, 0.0d0, tolng, tolat) + sw0003=(memi(cooout+22) ) + goto 220 +230 continue + olng(i) = ((tolng)*57.295779513082320877) / 15.0d0 + goto 221 +240 continue + olng(i) = ((tolng)*57.295779513082320877) + goto 221 +250 continue + olng(i) = tolng + goto 221 +260 continue + olng(i) = tolng + goto 221 +220 continue + if (sw0003.lt.1.or.sw0003.gt.3) goto 260 + goto (240,250,230),sw0003 +221 continue + sw0004=(memi(cooout+23) ) + goto 270 +280 continue + olat(i) = ((tolat)*57.295779513082320877) / 15.0d0 + goto 271 +290 continue + olat(i) = ((tolat)*57.295779513082320877) + goto 271 +300 continue + olat(i) = tolat + goto 271 +310 continue + olat(i) = tolat + goto 271 +270 continue + if (sw0004.lt.1.or.sw0004.gt.3) goto 310 + goto (290,300,280),sw0004 +271 continue +110 continue +111 continue +100 return + end + subroutine sklltn (cooin, cooout, ilng, ilat, ipmlng, ipmlat, px, + *rv, olng, olat) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer cooin + integer cooout + double precision ilng + double precision ilat + double precision ipmlng + double precision ipmlat + double precision px + double precision rv + double precision olng + double precision olat + integer pmflag + double precision pmr + double precision pmd + double precision slepj + double precision slepb + integer sw0001,sw0002,sw0003,sw0004,sw0005,sw0006,sw0007,sw0008, + *sw0009,sw0010 + save + if (.not.(memi(cooin+12) .eq. memi(cooout+12) )) goto 110 + sw0001=(memi(cooin+12) ) + goto 120 +130 continue + call skequl (cooin, cooout, ilng, ilat, ipmlng, ipmlat, + * px, rv, olng, olat) + goto 121 +140 continue + if (.not.(memd((((cooin+10)-1)/2+1)) .eq. memd((((cooout+ + * 10)-1)/2+1)) )) goto 150 + olng = ilng + olat = ilat + goto 151 +150 continue + call sleceq (ilng, ilat, memd((((cooin+10)-1)/2+1)) , + * olng, olat) + call sleqec (olng, olat, memd((((cooout+10)-1)/2+1)) , + * olng, olat) +151 continue + goto 121 +160 continue + olng = ilng + olat = ilat + goto 121 +120 continue + if (sw0001.eq.1) goto 130 + if (sw0001.eq.2) goto 140 + goto 160 +121 continue + goto 100 +110 continue + if (.not.(.not. ((ipmlng).eq.1.6d308) .and. .not. ((ipmlat).eq. + * 1.6d308))) goto 170 + pmflag = 1 + goto 171 +170 continue + pmflag = 0 +171 continue + sw0002=(memi(cooin+12) ) + goto 180 +190 continue + sw0003=(memi(cooin+13) ) + goto 200 +210 continue + if (.not.(pmflag .eq. 1)) goto 220 + call slpm (ilng, ilat, ipmlng, ipmlat, px, rv, slepb ( + * memd((((cooin+10)-1)/2+1)) ), slepb (memd((((cooout+10 + * )-1)/2+1)) ), olng, olat) + goto 221 +220 continue + olng = ilng + olat = ilat +221 continue + if (.not.(memi(cooin+13) .eq. 1)) goto 230 + call slsuet (olng, olat, memd((((cooin+8)-1)/2+1)) , + * olng, olat) +230 continue + if (.not.(memd((((cooin+8)-1)/2+1)) .ne. 1950.0d0)) goto + * 240 + call slprcs (1, memd((((cooin+8)-1)/2+1)) , 1950.0d0, + * olng, olat) +240 continue + call sladet (olng, olat, 1950.0d0, olng, olat) + if (.not.(pmflag .eq. 1)) goto 250 + call slf45z (olng, olat, slepb(memd((((cooout+10)-1)/2 + * +1)) ), olng, olat) + goto 251 +250 continue + call slf45z (olng, olat, slepb (memd((((cooin+10)-1)/2 + * +1)) ), olng, olat) +251 continue + goto 201 +260 continue + if (.not.(pmflag .eq. 1)) goto 270 + call slpm (ilng, ilat, ipmlng, ipmlat, px, rv, slepj ( + * memd((((cooin+10)-1)/2+1)) ), slepj(memd((((cooout+10) + * -1)/2+1)) ), olng, olat) + goto 271 +270 continue + olng = ilng + olat = ilat +271 continue + if (.not.(memd((((cooin+8)-1)/2+1)) .ne. 2000.0d0)) goto + * 280 + call slprcs (2, memd((((cooin+8)-1)/2+1)) , 2000.0d0, + * olng, olat) +280 continue + goto 201 +290 continue + if (.not.(pmflag .eq. 1)) goto 300 + call slpm (ilng, ilat, ipmlng, ipmlat, px, rv, slepj ( + * memd((((cooin+10)-1)/2+1)) ), slepj(memd((((cooout+10) + * -1)/2+1)) ), olng, olat) + goto 301 +300 continue + olng = ilng + olat = ilat +301 continue + if (.not.(memd((((cooin+8)-1)/2+1)) .ne. 2000.0d0)) goto + * 310 + call slprcs (2, memd((((cooin+8)-1)/2+1)) , 2000.0d0, + * olng, olat) +310 continue + call slhf5z (olng, olat, 2000.0d0, olng, olat, pmr, pmd) + goto 201 +320 continue + call slamp (ilng, ilat, memd((((cooin+10)-1)/2+1)) , 2000 + * .0d0, olng, olat) + goto 201 +200 continue + if (sw0003.lt.1.or.sw0003.gt.5) goto 201 + goto (210,210,260,290,320),sw0003 +201 continue + sw0004=(memi(cooout+12) ) + goto 330 +340 continue + call sleqec (olng, olat, memd((((cooout+10)-1)/2+1)) , + * olng, olat) + goto 331 +350 continue + call sleqga (olng, olat, olng, olat) + goto 331 +360 continue + call sleqga (olng, olat, olng, olat) + call slgasu (olng, olat, olng, olat) + goto 331 +370 continue + olng = ilng + olat = ilat + goto 331 +330 continue + sw0004=sw0004-1 + if (sw0004.lt.1.or.sw0004.gt.3) goto 370 + goto (340,350,360),sw0004 +331 continue + goto 181 +380 continue + call sleceq (ilng, ilat, memd((((cooin+10)-1)/2+1)) , olng, + * olat) + sw0005=(memi(cooout+12) ) + goto 390 +400 continue + sw0006=(memi(cooout+13) ) + goto 410 +420 continue + call slf54z (olng, olat, slepb(memd((((cooout+10)-1)/2 + * +1)) ), olng, olat, pmr, pmd) + call slsuet (olng, olat, 1950.0d0, olng, olat) + if (.not.(memd((((cooout+8)-1)/2+1)) .ne. 1950.0d0)) + * goto 430 + call slprcs (1, 1950.0d0, memd((((cooout+8)-1)/2+1) + * ) , olng, olat) +430 continue + if (.not.(memi(cooout+13) .eq. 1)) goto 440 + call sladet (olng, olat, memd((((cooout+8)-1)/2+1)) + * , olng, olat) +440 continue + goto 411 +450 continue + if (.not.(memd((((cooout+8)-1)/2+1)) .ne. 2000.0d0)) + * goto 460 + call slprcs (2, 2000.0d0, memd((((cooout+8)-1)/2+1) + * ) , olng, olat) +460 continue + goto 411 +470 continue + call slf5hz (olng, olat, 2000.0d0, olng, olat) + if (.not.(memd((((cooout+8)-1)/2+1)) .ne. 2000.0d0)) + * goto 480 + call slprcs (2, 2000.0d0, memd((((cooout+8)-1)/2+1) + * ) , olng, olat) +480 continue + goto 411 +490 continue + call slmap (olng, olat, 0.0d0, 0.0d0, px, 0.0d0, 2000. + * 0d0, memd((((cooout+10)-1)/2+1)) , olng, olat) + goto 411 +410 continue + if (sw0006.lt.1.or.sw0006.gt.5) goto 411 + goto (420,420,450,470,490),sw0006 +411 continue + goto 391 +500 continue + call sleqga (olng, olat, olng, olat) + goto 391 +510 continue + call sleqga (olng, olat, olng, olat) + call slgasu (olng, olat, olng, olat) + goto 391 +520 continue + olng = ilng + olat = ilat + goto 391 +390 continue + if (sw0005.lt.1.or.sw0005.gt.4) goto 520 + goto (400,520,500,510),sw0005 +391 continue + goto 181 +530 continue + sw0007=(memi(cooout+12) ) + goto 540 +550 continue + call slgaeq (ilng, ilat, olng, olat) + sw0008=(memi(cooout+13) ) + goto 560 +570 continue + call slf54z (olng, olat, slepb(memd((((cooout+10)-1)/2 + * +1)) ), olng, olat, pmr, pmd) + call slsuet (olng, olat, 1950.0d0, olng, olat) + if (.not.(memd((((cooout+8)-1)/2+1)) .ne. 1950.0d0)) + * goto 580 + call slprcs (1, 1950.0d0, memd((((cooout+8)-1)/2+1) + * ) , olng, olat) +580 continue + if (.not.(memi(cooout+13) .eq. 1)) goto 590 + call sladet (olng, olat, memd((((cooout+8)-1)/2+1)) + * , olng, olat) +590 continue + goto 561 +600 continue + if (.not.(memd((((cooout+8)-1)/2+1)) .ne. 2000.0d0)) + * goto 610 + call slprcs (2, 2000.0d0, memd((((cooout+8)-1)/2+1) + * ) , olng, olat) +610 continue + goto 561 +620 continue + call slf5hz (olng, olat, 2000.0d0, olng, olat) + if (.not.(memd((((cooout+8)-1)/2+1)) .ne. 2000.0d0)) + * goto 630 + call slprcs (2, 2000.0d0, memd((((cooout+8)-1)/2+1) + * ) , olng, olat) +630 continue + goto 561 +640 continue + call slmap (olng, olat, 0.0d0, 0.0d0, px, 0.0d0, 2000. + * 0d0, memd((((cooout+10)-1)/2+1)) , olng, olat) + goto 561 +560 continue + if (sw0008.lt.1.or.sw0008.gt.5) goto 561 + goto (570,570,600,620,640),sw0008 +561 continue + goto 541 +650 continue + call slgaeq (ilng, ilat, olng, olat) + call sleqec (olng, olat, memd((((cooout+10)-1)/2+1)) , + * olng, olat) + goto 541 +660 continue + call slgasu (ilng, ilat, olng, olat) + goto 541 +670 continue + olng = ilng + olat = ilat + goto 541 +540 continue + if (sw0007.lt.1.or.sw0007.gt.4) goto 670 + goto (550,650,670,660),sw0007 +541 continue + goto 181 +680 continue + sw0009=(memi(cooout+12) ) + goto 690 +700 continue + call slsuga (ilng, ilat, olng, olat) + sw0010=(memi(cooout+13) ) + goto 710 +720 continue + call slgaeq (olng, olat, olng, olat) + call slf54z (olng, olat, slepb (memd((((cooout+10)-1)/ + * 2+1)) ), olng, olat, pmr, pmd) + call slsuet (olng, olat, 1950.0d0, olng, olat) + if (.not.(memd((((cooout+8)-1)/2+1)) .ne. 1950.0d0)) + * goto 730 + call slprcs (1, 1950.0d0, memd((((cooout+8)-1)/2+1) + * ) , olng, olat) +730 continue + call sladet (olng, olat, memd((((cooout+8)-1)/2+1)) , + * olng, olat) + goto 711 +740 continue + call slgaeq (olng, olat, olng, olat) + call slf54z (olng, olat, slepb (memd((((cooout+10)-1)/ + * 2+1)) ), olng, olat, pmr, pmd) + call slsuet (olng, olat, 1950.0d0, olng, olat) + if (.not.(memd((((cooout+8)-1)/2+1)) .ne. 1950.0d0)) + * goto 750 + call slprcs (1, 1950.0d0, memd((((cooout+8)-1)/2+1) + * ) , olng, olat) +750 continue + goto 711 +760 continue + call slgaeq (olng, olat, olng, olat) + if (.not.(memd((((cooout+8)-1)/2+1)) .ne. 2000.0d0)) + * goto 770 + call slprcs (2, 2000.0d0, memd((((cooout+8)-1)/2+1) + * ) , olng, olat) +770 continue + goto 711 +780 continue + call slgaeq (olng, olat, olng, olat) + call slf5hz (olng, olat, 2000.0d0, olng, olat) + if (.not.(memd((((cooout+8)-1)/2+1)) .ne. 2000.0d0)) + * goto 790 + call slprcs (2, 2000.0d0, memd((((cooout+8)-1)/2+1) + * ) , olng, olat) +790 continue + goto 711 +800 continue + call slgaeq (olng, olat, olng, olat) + call slmap (olng, olat, 0.0d0, 0.0d0, px, 0.0d0, 2000. + * 0d0, memd((((cooout+10)-1)/2+1)) , olng, olat) + goto 711 +710 continue + if (sw0010.lt.1.or.sw0010.gt.5) goto 711 + goto (720,740,760,780,800),sw0010 +711 continue + goto 691 +810 continue + call slsuga (ilng, ilat, olng, olat) + call slgaeq (olng, olat, olng, olat) + call sleqec (olng, olat, memd((((cooout+10)-1)/2+1)) , + * olng, olat) + goto 691 +820 continue + call slsuga (ilng, ilat, olng, olat) + goto 691 +830 continue + olng = ilng + olat = ilat + goto 691 +690 continue + if (sw0009.lt.1.or.sw0009.gt.3) goto 830 + goto (700,810,820),sw0009 +691 continue + goto 181 +840 continue + olng = ilng + olat = ilat + goto 181 +180 continue + if (sw0002.lt.1.or.sw0002.gt.4) goto 840 + goto (190,380,530,680),sw0002 +181 continue +100 return + end + subroutine skequl (cooin, cooout, ilng, ilat, ipmlng, ipmlat, px, + *rv, olng, olat) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer cooin + integer cooout + double precision ilng + double precision ilat + double precision ipmlng + double precision ipmlat + double precision px + double precision rv + double precision olng + double precision olat + integer pmflag + double precision pmr + double precision pmd + double precision slepb + double precision slepj + integer sw0001,sw0002,sw0003,sw0004 + save + if (.not.((memi(cooin+13) .eq. memi(cooout+13) ) .and. (memd((( + * (cooin+8)-1)/2+1)) .eq. memd((((cooout+8)-1)/2+1)) ) .and. ( + * memd((((cooin+10)-1)/2+1)) .eq. memd((((cooout+10)-1)/2+1)) ))) + * goto 110 + olng = ilng + olat = ilat + goto 100 +110 continue + if (.not.(.not. ((ipmlng).eq.1.6d308) .and. .not. ((ipmlat).eq. + * 1.6d308))) goto 120 + pmflag = 1 + goto 121 +120 continue + pmflag = 0 +121 continue + sw0001=(memi(cooin+13) ) + goto 130 +140 continue + if (.not.(pmflag .eq. 1)) goto 150 + call slpm (ilng, ilat, ipmlng, ipmlat, px, rv, slepb ( + * memd((((cooin+10)-1)/2+1)) ), slepb (memd((((cooout+10)-1 + * )/2+1)) ), olng, olat) + goto 151 +150 continue + olng = ilng + olat = ilat +151 continue + if (.not.(memi(cooin+13) .eq. 1)) goto 160 + call slsuet (olng, olat, memd((((cooin+8)-1)/2+1)) , olng + * , olat) +160 continue + if (.not.(memd((((cooin+8)-1)/2+1)) .ne. 1950.0d0)) goto 170 + call slprcs (1, memd((((cooin+8)-1)/2+1)) , 1950.0d0, + * olng, olat) +170 continue + call sladet (olng, olat, 1950.0d0, olng, olat) + if (.not.(pmflag .eq. 1)) goto 180 + call slf45z (olng, olat, slepb (memd((((cooout+10)-1)/2+1 + * )) ), olng, olat) + goto 181 +180 continue + call slf45z (olng, olat, slepb (memd((((cooin+10)-1)/2+1) + * ) ), olng, olat) +181 continue + sw0002=(memi(cooout+13) ) + goto 190 +200 continue + call slf54z (olng, olat, slepb (memd((((cooout+10)-1)/2+1 + * )) ), olng, olat, pmr, pmd) + call slsuet (olng, olat, 1950.0d0, olng, olat) + if (.not.(memd((((cooout+8)-1)/2+1)) .ne. 1950.0d0)) goto + * 210 + call slprcs (1, 1950.0d0, memd((((cooout+8)-1)/2+1)) , + * olng, olat) +210 continue + if (.not.(memi(cooout+13) .eq. 1)) goto 220 + call sladet (olng, olat, memd((((cooout+8)-1)/2+1)) , + * olng, olat) +220 continue + goto 191 +230 continue + if (.not.(memd((((cooout+8)-1)/2+1)) .ne. 2000.0d0)) goto + * 240 + call slprcs (2, 2000.0d0, memd((((cooout+8)-1)/2+1)) , + * olng, olat) +240 continue + goto 191 +250 continue + call slf5hz (olng, olat, 2000.0d0, olng, olat) + if (.not.(memd((((cooout+8)-1)/2+1)) .ne. 2000.0d0)) goto + * 260 + call slprcs (2, 2000.0d0, memd((((cooout+8)-1)/2+1)) , + * olng, olat) +260 continue + goto 191 +270 continue + call slmap (olng, olat, 0.0d0, 0.0d0, px, 0.0d0, 2000.0d0 + * , memd((((cooout+10)-1)/2+1)) , olng, olat) + goto 191 +190 continue + if (sw0002.lt.1.or.sw0002.gt.5) goto 191 + goto (200,200,230,250,270),sw0002 +191 continue + goto 131 +280 continue + if (.not.(memi(cooin+13) .eq. 3)) goto 290 + if (.not.(pmflag .eq. 1)) goto 300 + call slpm (ilng, ilat, ipmlng, ipmlat, px, rv, slepj ( + * memd((((cooin+10)-1)/2+1)) ), slepj (memd((((cooout+10 + * )-1)/2+1)) ), olng, olat) + goto 301 +300 continue + olng = ilng + olat = ilat +301 continue + goto 291 +290 continue + call slamp (ilng, ilat, memd((((cooin+10)-1)/2+1)) , 2000 + * .0d0, olng, olat) +291 continue + sw0003=(memi(cooout+13) ) + goto 310 +320 continue + if (.not.(memd((((cooin+8)-1)/2+1)) .ne. 2000.0d0)) goto + * 330 + call slprcs (2, memd((((cooin+8)-1)/2+1)) , 2000.0d0, + * olng, olat) +330 continue + call slf54z (olng, olat, slepb(memd((((cooout+10)-1)/2+1) + * ) ), olng, olat, pmr, pmd) + call slsuet (olng, olat, 1950.0d0, olng, olat) + if (.not.(memd((((cooout+8)-1)/2+1)) .ne. 1950.0d0)) goto + * 340 + call slprcs (1, 1950.0d0, memd((((cooout+8)-1)/2+1)) , + * olng, olat) +340 continue + if (.not.(memi(cooout+13) .eq. 1)) goto 350 + call sladet (olng, olat, memd((((cooout+8)-1)/2+1)) , + * olng, olat) +350 continue + goto 311 +360 continue + if (.not.(memd((((cooin+8)-1)/2+1)) .ne. memd((((cooout+8 + * )-1)/2+1)) )) goto 370 + call slprcs (2, memd((((cooin+8)-1)/2+1)) , memd(((( + * cooout+8)-1)/2+1)) , olng, olat) +370 continue + goto 311 +380 continue + if (.not.(memd((((cooin+8)-1)/2+1)) .ne. 2000.0d0)) goto + * 390 + call slprcs (2, memd((((cooin+8)-1)/2+1)) , 2000.0d0, + * olng, olat) +390 continue + call slf5hz (olng, olat, slepj(memd((((cooin+10)-1)/2+1)) + * ), olng, olat) + if (.not.(memd((((cooout+8)-1)/2+1)) .ne. 2000.0d0)) goto + * 400 + call slprcs (2, 2000.0d0, memd((((cooout+8)-1)/2+1)) , + * olng, olat) +400 continue + goto 311 +410 continue + if (.not.(memd((((cooin+8)-1)/2+1)) .ne. 2000.0d0)) goto + * 420 + call slprcs (2, memd((((cooin+8)-1)/2+1)) , 2000.0d0, + * olng, olat) +420 continue + call slmap (olng, olat, 0.0d0, 0.0d0, px, 0.0d0, 2000.0d0 + * , memd((((cooout+10)-1)/2+1)) , olng, olat) + goto 311 +310 continue + if (sw0003.lt.1.or.sw0003.gt.5) goto 311 + goto (320,320,360,380,410),sw0003 +311 continue + goto 131 +430 continue + if (.not.(pmflag .eq. 1)) goto 440 + call slpm (ilng, ilat, ipmlng, ipmlat, px, rv, slepj ( + * memd((((cooin+10)-1)/2+1)) ), slepj (memd((((cooout+10)-1 + * )/2+1)) ), olng, olat) + goto 441 +440 continue + olng = ilng + olat = ilat +441 continue + sw0004=(memi(cooout+13) ) + goto 450 +460 continue + if (.not.(memd((((cooin+8)-1)/2+1)) .ne. 2000.0d0)) goto + * 470 + call slprcs (2, memd((((cooin+8)-1)/2+1)) , 2000.0d0, + * olng, olat) +470 continue + call slhf5z (olng, olat, 2000.0d0, olng, olat, pmr, pmd) + call slf54z (olng, olat, slepb(memd((((cooout+10)-1)/2+1) + * ) ), olng, olat, pmr, pmd) + call slsuet (olng, olat, 1950.0d0, olng, olat) + if (.not.(memd((((cooout+8)-1)/2+1)) .ne. 1950.0d0)) goto + * 480 + call slprcs (1, 1950.0d0, memd((((cooout+8)-1)/2+1)) , + * olng, olat) +480 continue + if (.not.(memi(cooout+13) .eq. 1)) goto 490 + call sladet (olng, olat, memd((((cooout+8)-1)/2+1)) , + * olng, olat) +490 continue + goto 451 +500 continue + if (.not.(memd((((cooin+8)-1)/2+1)) .ne. 2000.0d0)) goto + * 510 + call slprcs (2, memd((((cooin+8)-1)/2+1)) , 2000.0d0, + * olng, olat) +510 continue + call slhf5z (olng, olat, slepj(memd((((cooout+10)-1)/2+1) + * ) ), olng, olat, pmr, pmd) + if (.not.(memd((((cooout+8)-1)/2+1)) .ne. 2000.0d0)) goto + * 520 + call slprcs (2, 2000.0d0, memd((((cooout+8)-1)/2+1)) , + * olng, olat) +520 continue + goto 451 +530 continue + if (.not.(memd((((cooin+8)-1)/2+1)) .ne. memd((((cooout+8 + * )-1)/2+1)) )) goto 540 + call slprcs (2, memd((((cooin+8)-1)/2+1)) , memd(((( + * cooout+8)-1)/2+1)) , olng, olat) +540 continue + goto 451 +550 continue + if (.not.(memd((((cooin+8)-1)/2+1)) .ne. 2000.0d0)) goto + * 560 + call slprcs (2, memd((((cooin+8)-1)/2+1)) , 2000.0d0, + * olng, olat) +560 continue + call slhf5z (olng, olat, slepj(memd((((cooout+10)-1)/2+1) + * ) ), olng, olat, pmr, pmd) + call slmap (olng, olat, 0.0d0, 0.0d0, px, 0.0d0, 2000.0d0 + * , memd((((cooout+10)-1)/2+1)) , olng, olat) + goto 451 +450 continue + if (sw0004.lt.1.or.sw0004.gt.5) goto 451 + goto (460,460,500,530,550),sw0004 +451 continue + goto 131 +130 continue + if (sw0001.lt.1.or.sw0001.gt.5) goto 131 + goto (140,140,280,430,280),sw0001 +131 continue +100 return + end +c sleceq sl_eceq +c sleqec sl_eqec +c sladet sl_adet +c sleqga sl_eqga +c slgaeq sl_gaeq +c slf45z sl_f45z +c slf54z sl_f54z +c slhf5z sl_hf5z +c slf5hz sl_f5hz +c slgasu sl_gasu +c slsuga sl_suga +c skequl sk_equatorial +c sklltn sk_lltran +c slprcs sl_prcs +c skultn sk_ultran +c slsuet sl_suet diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/sktransform.x b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/sktransform.x new file mode 100644 index 00000000..a8cf87c3 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/sktransform.x @@ -0,0 +1,577 @@ +include <math.h> +include "skywcsdef.h" +include "skywcs.h" + +# SK_ULTRAN -- Transform the sky coordinates from the input coordinate +# system to the output coordinate system using the units conversions as +# appropriate. + +procedure sk_ultran (cooin, cooout, ilng, ilat, olng, olat, npts) + +pointer cooin #I pointer to the input coordinate system structure +pointer cooout #I pointer to the output coordinate system structure +double ilng[ARB] #I the input ra/longitude in radians +double ilat[ARB] #I the input dec/latitude in radians +double olng[ARB] #O the output ra/longitude in radians +double olat[ARB] #O the output dec/latitude in radians +int npts #I the number of points to be converted + +double tilng, tilat, tolng, tolat +int i + +begin + do i = 1, npts { + + switch (SKY_NLNGUNITS(cooin)) { + case SKY_HOURS: + tilng = DEGTORAD(15.0d0 * ilng[i]) + case SKY_DEGREES: + tilng = DEGTORAD(ilng[i]) + case SKY_RADIANS: + tilng = ilng[i] + default: + tilng = ilng[i] + } + switch (SKY_NLATUNITS(cooin)) { + case SKY_HOURS: + tilat = DEGTORAD(15.0d0 * ilat[i]) + case SKY_DEGREES: + tilat = DEGTORAD(ilat[i]) + case SKY_RADIANS: + tilat = ilat[i] + default: + tilat = ilat[i] + } + + call sk_lltran (cooin, cooout, tilng, tilat, INDEFD, INDEFD, + 0.0d0, 0.0d0, tolng, tolat) + + switch (SKY_NLNGUNITS(cooout)) { + case SKY_HOURS: + olng[i] = RADTODEG(tolng) / 15.0d0 + case SKY_DEGREES: + olng[i] = RADTODEG(tolng) + case SKY_RADIANS: + olng[i] = tolng + default: + olng[i] = tolng + } + switch (SKY_NLATUNITS(cooout)) { + case SKY_HOURS: + olat[i] = RADTODEG(tolat) / 15.0d0 + case SKY_DEGREES: + olat[i] = RADTODEG(tolat) + case SKY_RADIANS: + olat[i] = tolat + default: + olat[i] = tolat + } + } +end + + +# SK_LLTRAN -- Transform the sky coordinate from the input coordinate +# system to the output coordinate system assuming that all the coordinate +# are in radians. + +procedure sk_lltran (cooin, cooout, ilng, ilat, ipmlng, ipmlat, px, rv, + olng, olat) + +pointer cooin #I pointer to the input coordinate system structure +pointer cooout #I pointer to the output coordinate system structure +double ilng #I the input ra/longitude in radians +double ilat #I the input dec/latitude in radians +double ipmlng #I the input proper motion in ra in radians +double ipmlat #I the input proper motion in dec in radians +double px #I the input parallax in arcseconds +double rv #I the input radial velocity in km / second +double olng #O the output ra/longitude in radians +double olat #O the output dec/latitude in radians + +int pmflag +double pmr, pmd +double sl_epj(), sl_epb() + +begin + # Test for the case where the input coordinate system is the + # same as the output coordinate system. + if (SKY_CTYPE(cooin) == SKY_CTYPE(cooout)) { + + switch (SKY_CTYPE(cooin)) { + + case CTYPE_EQUATORIAL: + call sk_equatorial (cooin, cooout, ilng, ilat, ipmlng, + ipmlat, px, rv, olng, olat) + + case CTYPE_ECLIPTIC: + if (SKY_EPOCH(cooin) == SKY_EPOCH(cooout)) { + olng = ilng + olat = ilat + } else { + call sl_eceq (ilng, ilat, SKY_EPOCH(cooin), olng, olat) + call sl_eqec (olng, olat, SKY_EPOCH(cooout), olng, olat) + } + + default: + olng = ilng + olat = ilat + } + + return + } + + # Compute proper motions ? + if (! IS_INDEFD(ipmlng) && ! IS_INDEFD(ipmlat)) + pmflag = YES + else + pmflag = NO + + # Cover the remaining cases. + switch (SKY_CTYPE(cooin)) { + + # The input system is equatorial. + case CTYPE_EQUATORIAL: + + switch (SKY_RADECSYS(cooin)) { + + case EQTYPE_FK4, EQTYPE_FK4NOE: + if (pmflag == YES) { + call sl_pm (ilng, ilat, ipmlng, ipmlat, px, rv, + sl_epb (SKY_EPOCH(cooin)), sl_epb (SKY_EPOCH(cooout)), + olng, olat) + } else { + olng = ilng + olat = ilat + } + if (SKY_RADECSYS(cooin) == EQTYPE_FK4) + call sl_suet (olng, olat, SKY_EQUINOX(cooin), olng, olat) + if (SKY_EQUINOX(cooin) != 1950.0d0) + call sl_prcs (1, SKY_EQUINOX(cooin), 1950.0d0, olng, olat) + call sl_adet (olng, olat, 1950.0d0, olng, olat) + if (pmflag == YES) + call sl_f45z (olng, olat, sl_epb(SKY_EPOCH(cooout)), + olng, olat) + else + call sl_f45z (olng, olat, sl_epb (SKY_EPOCH(cooin)), + olng, olat) + + case EQTYPE_FK5: + if (pmflag == YES) { + call sl_pm (ilng, ilat, ipmlng, ipmlat, px, rv, + sl_epj (SKY_EPOCH(cooin)), sl_epj(SKY_EPOCH(cooout)), + olng, olat) + } else { + olng = ilng + olat = ilat + } + if (SKY_EQUINOX(cooin) != 2000.0d0) + call sl_prcs (2, SKY_EQUINOX(cooin), 2000.0d0, olng, olat) + + case EQTYPE_ICRS: + if (pmflag == YES) { + call sl_pm (ilng, ilat, ipmlng, ipmlat, px, rv, + sl_epj (SKY_EPOCH(cooin)), sl_epj(SKY_EPOCH(cooout)), + olng, olat) + } else { + olng = ilng + olat = ilat + } + if (SKY_EQUINOX(cooin) != 2000.0d0) + call sl_prcs (2, SKY_EQUINOX(cooin), 2000.0d0, olng, olat) + call sl_hf5z (olng, olat, 2000.0d0, olng, olat, pmr, pmd) + + case EQTYPE_GAPPT: + call sl_amp (ilng, ilat, SKY_EPOCH(cooin), 2000.0d0, olng, olat) + + } + + switch (SKY_CTYPE(cooout)) { + + # The output coordinate system is ecliptic. + case CTYPE_ECLIPTIC: + call sl_eqec (olng, olat, SKY_EPOCH(cooout), olng, olat) + + # The output coordinate system is galactic. + case CTYPE_GALACTIC: + call sl_eqga (olng, olat, olng, olat) + + # The output coordinate system is supergalactic. + case CTYPE_SUPERGALACTIC: + call sl_eqga (olng, olat, olng, olat) + call sl_gasu (olng, olat, olng, olat) + + default: + olng = ilng + olat = ilat + } + + # The input coordinate system is ecliptic. + case CTYPE_ECLIPTIC: + + call sl_eceq (ilng, ilat, SKY_EPOCH(cooin), olng, olat) + switch (SKY_CTYPE(cooout)) { + + # The output coordinate system is equatorial. + case CTYPE_EQUATORIAL: + + switch (SKY_RADECSYS(cooout)) { + case EQTYPE_FK4, EQTYPE_FK4NOE: + call sl_f54z (olng, olat, sl_epb(SKY_EPOCH(cooout)), + olng, olat, pmr, pmd) + call sl_suet (olng, olat, 1950.0d0, olng, olat) + if (SKY_EQUINOX(cooout) != 1950.0d0) + call sl_prcs (1, 1950.0d0, SKY_EQUINOX(cooout), + olng, olat) + if (SKY_RADECSYS(cooout) == EQTYPE_FK4) + call sl_adet (olng, olat, SKY_EQUINOX(cooout), + olng, olat) + + case EQTYPE_FK5: + if (SKY_EQUINOX(cooout) != 2000.0d0) + call sl_prcs (2, 2000.0d0, SKY_EQUINOX(cooout), + olng, olat) + + case EQTYPE_ICRS: + #call sl_f5hz (olng, olat, sl_epj(SKY_EPOCH(cooin)), + #olng, olat) + call sl_f5hz (olng, olat, 2000.0d0, olng, olat) + if (SKY_EQUINOX(cooout) != 2000.0d0) + call sl_prcs (2, 2000.0d0, SKY_EQUINOX(cooout), + olng, olat) + + case EQTYPE_GAPPT: + call sl_map (olng, olat, 0.0d0, 0.0d0, px, 0.0d0, + 2000.0d0, SKY_EPOCH(cooout), olng, olat) + } + + # The output coordinate system is galactic. + case CTYPE_GALACTIC: + call sl_eqga (olng, olat, olng, olat) + + # The output system is supergalactic. + case CTYPE_SUPERGALACTIC: + call sl_eqga (olng, olat, olng, olat) + call sl_gasu (olng, olat, olng, olat) + + default: + olng = ilng + olat = ilat + } + + # The input coordinate system is galactic. + case CTYPE_GALACTIC: + + switch (SKY_CTYPE(cooout)) { + + # The output coordinate system is equatorial. + case CTYPE_EQUATORIAL: + call sl_gaeq (ilng, ilat, olng, olat) + + switch (SKY_RADECSYS(cooout)) { + case EQTYPE_FK4, EQTYPE_FK4NOE: + call sl_f54z (olng, olat, sl_epb(SKY_EPOCH(cooout)), + olng, olat, pmr, pmd) + call sl_suet (olng, olat, 1950.0d0, olng, olat) + if (SKY_EQUINOX(cooout) != 1950.0d0) + call sl_prcs (1, 1950.0d0, SKY_EQUINOX(cooout), + olng, olat) + if (SKY_RADECSYS(cooout) == EQTYPE_FK4) + call sl_adet (olng, olat, SKY_EQUINOX(cooout), + olng, olat) + + case EQTYPE_FK5: + if (SKY_EQUINOX(cooout) != 2000.0d0) + call sl_prcs (2, 2000.0d0, SKY_EQUINOX(cooout), + olng, olat) + + case EQTYPE_ICRS: + call sl_f5hz (olng, olat, 2000.0d0, olng, olat) + if (SKY_EQUINOX(cooout) != 2000.0d0) + call sl_prcs (2, 2000.0d0, SKY_EQUINOX(cooout), + olng, olat) + + case EQTYPE_GAPPT: + call sl_map (olng, olat, 0.0d0, 0.0d0, px, 0.0d0, + 2000.0d0, SKY_EPOCH(cooout), olng, olat) + } + + # The output coordinate system is ecliptic. + case CTYPE_ECLIPTIC: + call sl_gaeq (ilng, ilat, olng, olat) + call sl_eqec (olng, olat, SKY_EPOCH(cooout), olng, olat) + + # The output coordinate system is supergalactic. + case CTYPE_SUPERGALACTIC: + call sl_gasu (ilng, ilat, olng, olat) + + default: + olng = ilng + olat = ilat + } + + # The input coordinates are supergalactic. + case CTYPE_SUPERGALACTIC: + + switch (SKY_CTYPE(cooout)) { + + case CTYPE_EQUATORIAL: + call sl_suga (ilng, ilat, olng, olat) + + switch (SKY_RADECSYS(cooout)) { + + case EQTYPE_FK4: + call sl_gaeq (olng, olat, olng, olat) + call sl_f54z (olng, olat, sl_epb (SKY_EPOCH(cooout)), + olng, olat, pmr, pmd) + call sl_suet (olng, olat, 1950.0d0, olng, olat) + if (SKY_EQUINOX(cooout) != 1950.0d0) + call sl_prcs (1, 1950.0d0, SKY_EQUINOX(cooout), + olng, olat) + call sl_adet (olng, olat, SKY_EQUINOX(cooout), olng, olat) + + case EQTYPE_FK4NOE: + call sl_gaeq (olng, olat, olng, olat) + call sl_f54z (olng, olat, sl_epb (SKY_EPOCH(cooout)), + olng, olat, pmr, pmd) + call sl_suet (olng, olat, 1950.0d0, olng, olat) + if (SKY_EQUINOX(cooout) != 1950.0d0) + call sl_prcs (1, 1950.0d0, SKY_EQUINOX(cooout), + olng, olat) + + case EQTYPE_FK5: + call sl_gaeq (olng, olat, olng, olat) + if (SKY_EQUINOX(cooout) != 2000.0d0) + call sl_prcs (2, 2000.0d0, SKY_EQUINOX(cooout), + olng, olat) + + case EQTYPE_ICRS: + call sl_gaeq (olng, olat, olng, olat) + call sl_f5hz (olng, olat, 2000.0d0, olng, olat) + if (SKY_EQUINOX(cooout) != 2000.0d0) + call sl_prcs (2, 2000.0d0, SKY_EQUINOX(cooout), + olng, olat) + + case EQTYPE_GAPPT: + call sl_gaeq (olng, olat, olng, olat) + call sl_map (olng, olat, 0.0d0, 0.0d0, px, 0.0d0, + 2000.0d0, SKY_EPOCH(cooout), olng, olat) + } + + case CTYPE_ECLIPTIC: + call sl_suga (ilng, ilat, olng, olat) + call sl_gaeq (olng, olat, olng, olat) + call sl_eqec (olng, olat, SKY_EPOCH(cooout), olng, olat) + + case CTYPE_GALACTIC: + call sl_suga (ilng, ilat, olng, olat) + + default: + olng = ilng + olat = ilat + } + + default: + olng = ilng + olat = ilat + } +end + + +# SK_EQUATORIAL -- Convert / precess equatorial coordinates. + +procedure sk_equatorial (cooin, cooout, ilng, ilat, ipmlng, ipmlat, + px, rv, olng, olat) + +pointer cooin #I the input coordinate system structure +pointer cooout #I the output coordinate system structure +double ilng #I the input ra in radians +double ilat #I the input dec in radians +double ipmlng #I the input proper motion in ra in radians +double ipmlat #I the input proper motion in dec in radians +double px #I the input parallax in arcseconds +double rv #I the input radial valocity in km / second +double olng #O the output ra in radians +double olat #O the output dec in radians + +int pmflag +double pmr, pmd +double sl_epb(), sl_epj() + +begin + # Check to see whether or not conversion / precession is necessary. + if ((SKY_RADECSYS(cooin) == SKY_RADECSYS(cooout)) && + (SKY_EQUINOX(cooin) == SKY_EQUINOX(cooout)) && + (SKY_EPOCH(cooin) == SKY_EPOCH(cooout))) { + olng = ilng + olat = ilat + return + } + + # Compute proper motions ? + if (! IS_INDEFD(ipmlng) && ! IS_INDEFD(ipmlat)) + pmflag = YES + else + pmflag = NO + + switch (SKY_RADECSYS(cooin)) { + + # The input coordinate system is FK4 with or without the E terms. + case EQTYPE_FK4, EQTYPE_FK4NOE: + + if (pmflag == YES) { + call sl_pm (ilng, ilat, ipmlng, ipmlat, px, rv, + sl_epb (SKY_EPOCH(cooin)), sl_epb (SKY_EPOCH(cooout)), + olng, olat) + } else { + olng = ilng + olat = ilat + } + if (SKY_RADECSYS(cooin) == EQTYPE_FK4) + call sl_suet (olng, olat, SKY_EQUINOX(cooin), olng, olat) + if (SKY_EQUINOX(cooin) != 1950.0d0) + call sl_prcs (1, SKY_EQUINOX(cooin), 1950.0d0, olng, olat) + call sl_adet (olng, olat, 1950.0d0, olng, olat) + if (pmflag == YES) + call sl_f45z (olng, olat, sl_epb (SKY_EPOCH(cooout)), + olng, olat) + else + call sl_f45z (olng, olat, sl_epb (SKY_EPOCH(cooin)), + olng, olat) + + switch (SKY_RADECSYS(cooout)) { + + # The output coordinate system is FK4 with and without the E terms. + case EQTYPE_FK4, EQTYPE_FK4NOE: + call sl_f54z (olng, olat, sl_epb (SKY_EPOCH(cooout)), + olng, olat, pmr, pmd) + call sl_suet (olng, olat, 1950.0d0, olng, olat) + if (SKY_EQUINOX(cooout) != 1950.0d0) + call sl_prcs (1, 1950.0d0, SKY_EQUINOX(cooout), + olng, olat) + if (SKY_RADECSYS(cooout) == EQTYPE_FK4) + call sl_adet (olng, olat, SKY_EQUINOX(cooout), olng, olat) + + # The output coordinate system is FK5. + case EQTYPE_FK5: + if (SKY_EQUINOX(cooout) != 2000.0d0) + call sl_prcs (2, 2000.0d0, SKY_EQUINOX(cooout), olng, olat) + + # The output coordinate system is ICRS (Hipparcos). + case EQTYPE_ICRS: + call sl_f5hz (olng, olat, 2000.0d0, olng, olat) + if (SKY_EQUINOX(cooout) != 2000.0d0) + call sl_prcs (2, 2000.0d0, SKY_EQUINOX(cooout), olng, olat) + + # The output coordinate system is geocentric apparent. + case EQTYPE_GAPPT: + call sl_map (olng, olat, 0.0d0, 0.0d0, px, 0.0d0, 2000.0d0, + SKY_EPOCH(cooout), olng, olat) + } + + # The input coordinate system is FK5 or geocentric apparent. + case EQTYPE_FK5, EQTYPE_GAPPT: + + if (SKY_RADECSYS(cooin) == EQTYPE_FK5) { + if (pmflag == YES) { + call sl_pm (ilng, ilat, ipmlng, ipmlat, px, rv, + sl_epj (SKY_EPOCH(cooin)), sl_epj (SKY_EPOCH(cooout)), + olng, olat) + } else { + olng = ilng + olat = ilat + } + } else + call sl_amp (ilng, ilat, SKY_EPOCH(cooin), 2000.0d0, olng, olat) + + switch (SKY_RADECSYS(cooout)) { + + # The output coordinate system is FK4 with or without the E terms. + case EQTYPE_FK4, EQTYPE_FK4NOE: + if (SKY_EQUINOX(cooin) != 2000.0d0) + call sl_prcs (2, SKY_EQUINOX(cooin), 2000.0d0, olng, olat) + call sl_f54z (olng, olat, sl_epb(SKY_EPOCH(cooout)), + olng, olat, pmr, pmd) + call sl_suet (olng, olat, 1950.0d0, olng, olat) + if (SKY_EQUINOX(cooout) != 1950.0d0) + call sl_prcs (1, 1950.0d0, SKY_EQUINOX(cooout), olng, olat) + if (SKY_RADECSYS(cooout) == EQTYPE_FK4) + call sl_adet (olng, olat, SKY_EQUINOX(cooout), olng, olat) + + # The output coordinate system is FK5. + case EQTYPE_FK5: + if (SKY_EQUINOX(cooin) != SKY_EQUINOX(cooout)) + call sl_prcs (2, SKY_EQUINOX(cooin), SKY_EQUINOX(cooout), + olng, olat) + + # The output coordinate system is ICRS. + case EQTYPE_ICRS: + if (SKY_EQUINOX(cooin) != 2000.0d0) + call sl_prcs (2, SKY_EQUINOX(cooin), 2000.0d0, olng, olat) + call sl_f5hz (olng, olat, sl_epj(SKY_EPOCH(cooin)), olng, olat) + if (SKY_EQUINOX(cooout) != 2000.0d0) + call sl_prcs (2, 2000.0d0, SKY_EQUINOX(cooout), olng, olat) + + # The output coordinate system is geocentric apparent. + case EQTYPE_GAPPT: + if (SKY_EQUINOX(cooin) != 2000.0d0) + call sl_prcs (2, SKY_EQUINOX(cooin), 2000.0d0, olng, olat) + call sl_map (olng, olat, 0.0d0, 0.0d0, px, 0.0d0, 2000.0d0, + SKY_EPOCH(cooout), olng, olat) + } + + # The input coordinate system is ICRS. + case EQTYPE_ICRS: + + if (pmflag == YES) { + call sl_pm (ilng, ilat, ipmlng, ipmlat, px, rv, + sl_epj (SKY_EPOCH(cooin)), sl_epj (SKY_EPOCH(cooout)), + olng, olat) + } else { + olng = ilng + olat = ilat + } + + switch (SKY_RADECSYS(cooout)) { + + # The output coordinate system is FK4 with or without the E terms. + case EQTYPE_FK4, EQTYPE_FK4NOE: + if (SKY_EQUINOX(cooin) != 2000.0d0) + call sl_prcs (2, SKY_EQUINOX(cooin), 2000.0d0, olng, olat) + call sl_hf5z (olng, olat, 2000.0d0, olng, olat, + pmr, pmd) + call sl_f54z (olng, olat, sl_epb(SKY_EPOCH(cooout)), olng, olat, + pmr, pmd) + call sl_suet (olng, olat, 1950.0d0, olng, olat) + if (SKY_EQUINOX(cooout) != 1950.0d0) + call sl_prcs (1, 1950.0d0, SKY_EQUINOX(cooout), olng, olat) + if (SKY_RADECSYS(cooout) == EQTYPE_FK4) + call sl_adet (olng, olat, SKY_EQUINOX(cooout), olng, olat) + + # The output coordinate system is FK5. + case EQTYPE_FK5: + if (SKY_EQUINOX(cooin) != 2000.0d0) + call sl_prcs (2, SKY_EQUINOX(cooin), 2000.0d0, olng, olat) + call sl_hf5z (olng, olat, sl_epj(SKY_EPOCH(cooout)), + olng, olat, pmr, pmd) + if (SKY_EQUINOX(cooout) != 2000.0d0) + call sl_prcs (2, 2000.0d0, SKY_EQUINOX(cooout), olng, olat) + + # The output coordinate system is ICRS. + case EQTYPE_ICRS: + if (SKY_EQUINOX(cooin) != SKY_EQUINOX(cooout)) + call sl_prcs (2, SKY_EQUINOX(cooin), SKY_EQUINOX(cooout), + olng, olat) + + # The output coordinate system is geocentric apparent. + case EQTYPE_GAPPT: + if (SKY_EQUINOX(cooin) != 2000.0d0) + call sl_prcs (2, SKY_EQUINOX(cooin), 2000.0d0, olng, olat) + call sl_hf5z (olng, olat, sl_epj(SKY_EPOCH(cooout)), + olng, olat, pmr, pmd) + call sl_map (olng, olat, 0.0d0, 0.0d0, px, 0.0d0, 2000.0d0, + SKY_EPOCH(cooout), olng, olat) + + } + + } +end diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skwrdstr.f b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skwrdstr.f new file mode 100644 index 00000000..41fd369e --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skwrdstr.f @@ -0,0 +1,45 @@ + integer function skwrdr (index, outstr, maxch, dict) + integer index + integer maxch + integer*2 outstr(*) + integer*2 dict(*) + integer i + integer len + integer start + integer count + integer xstrln + save + outstr(1) = 0 + if (.not.(dict(1) .eq. 0)) goto 110 + skwrdr = (0) + goto 100 +110 continue + count = 1 + len = xstrln(dict) + start = 2 +120 if (.not.(count .lt. index)) goto 122 + if (.not.(dict(start) .eq. dict(1))) goto 130 + count = count + 1 +130 continue + if (.not.(start .eq. len)) goto 140 + skwrdr = (0) + goto 100 +140 continue +121 start = start + 1 + goto 120 +122 continue + i = start +150 if (.not.(dict(i) .ne. 0 .and. dict(i) .ne. dict(1))) goto 152 + if (.not.(i - start + 1 .gt. maxch)) goto 160 + goto 152 +160 continue + outstr(i - start + 1) = dict(i) +151 i = i + 1 + goto 150 +152 continue + outstr(i - start + 1) = 0 + skwrdr = (count) + goto 100 +100 return + end +c skwrdr sk_wrdstr diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skwrdstr.x b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skwrdstr.x new file mode 100644 index 00000000..a7c6b359 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skwrdstr.x @@ -0,0 +1,53 @@ + +# SK_WRDSTR -- Search a dictionary string for a given string index number. +# This is the opposite function of strdic(), that returns the index for +# given string. The entries in the dictionary string are separated by +# a delimiter character which is the first character of the dictionary +# string. The index of the string found is returned as the function value. +# Otherwise, if there is no string for that index, a zero is returned. + +int procedure sk_wrdstr (index, outstr, maxch, dict) + +int index #I the string index +char outstr[ARB] #O the output string as found in dictionary +int maxch #I the maximum length of output string +char dict[ARB] #I the dictionary string + +int i, len, start, count + +int strlen() + +begin + # Clear output string + outstr[1] = EOS + + # Return if the dictionary is not long enough + if (dict[1] == EOS) + return (0) + + # Initialize counters + count = 1 + len = strlen (dict) + + # Search the dictionary string. This loop only terminates + # successfully if the index is found. Otherwise the procedure + # returns with and error condition. + for (start = 2; count < index; start = start + 1) { + if (dict[start] == dict[1]) + count = count + 1 + if (start == len) + return (0) + } + + # Extract the output string from the dictionary + for (i = start; dict[i] != EOS && dict[i] != dict[1]; i = i + 1) { + if (i - start + 1 > maxch) + break + outstr[i - start + 1] = dict[i] + } + + outstr[i - start + 1] = EOS + + # Return index for output string + return (count) +end diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skwrite.f b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skwrite.f new file mode 100644 index 00000000..223f8f1e --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skwrite.f @@ -0,0 +1,1014 @@ + subroutine skiipt (label, images, mw, coo) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer mw + integer coo + integer*2 label(*) + integer*2 images(*) + save + if (.not.(mw .eq. 0)) goto 110 + call skinpt (label, images, memi(coo+12) , memi(coo+13) , + * memd((((coo+8)-1)/2+1)) , memd((((coo+10)-1)/2+1)) ) + goto 111 +110 continue + call skimpt (label, images, memi(coo+12) , memi(coo+15) , + * memi(coo+16) , memi(coo+14) , memi(coo+19) , memi(coo+13) , + * memd((((coo+8)-1)/2+1)) , memd((((coo+10)-1)/2+1)) ) +111 continue +100 return + end + subroutine skiiwe (fd, label, images, mw, coo) + integer fd + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer mw + integer coo + integer*2 label(*) + integer*2 images(*) + save + if (.not.(mw .eq. 0)) goto 110 + call skinwe (fd, label, images, memi(coo+12) , memi(coo+13) + * , memd((((coo+8)-1)/2+1)) , memd((((coo+10)-1)/2+1)) ) + goto 111 +110 continue + call skimwe (fd, label, images, memi(coo+12) , memi(coo+15) + * , memi(coo+16) , memi(coo+14) , memi(coo+19) , memi(coo+13) + * , memd((((coo+8)-1)/2+1)) , memd((((coo+10)-1)/2+1)) ) +111 continue +100 return + end + subroutine skinpt (label, system, ctype, radecs, equinx, epoch) + integer ctype + integer radecs + double precision equinx + double precision epoch + integer*2 label(*) + integer*2 system(*) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer sp + integer radecr + double precision slepj + double precision slepb + integer skwrdr + integer sw0001,sw0002 + integer*2 st0001(30) + integer*2 st0002(4) + integer*2 st0003(36) + integer*2 st0004(37) + integer*2 st0005(46) + integer*2 st0006(46) + integer*2 st0007(31) + integer*2 st0008(37) + integer*2 st0009(31) + integer*2 st0010(37) + integer*2 st0011(36) + integer*2 st0012(37) + save + integer iyy + data (st0001(iyy),iyy= 1, 8) /124,102,107, 52,124,102,107, 52/ + data (st0001(iyy),iyy= 9,16) / 45,110,111, 45,101,124,102,107/ + data (st0001(iyy),iyy=17,24) / 53,124,105, 99,114,115,124,103/ + data (st0001(iyy),iyy=25,30) / 97,112,112,116,124, 0/ + data st0002 / 70, 75, 53, 0/ + data (st0003(iyy),iyy= 1, 8) / 37,115, 58, 32, 37,115, 32, 32/ + data (st0003(iyy),iyy= 9,16) / 67,111,111,114,100,105,110, 97/ + data (st0003(iyy),iyy=17,24) /116,101,115, 58, 32,101,113,117/ + data (st0003(iyy),iyy=25,32) / 97,116,111,114,105, 97,108, 32/ + data (st0003(iyy),iyy=33,36) / 37,115, 10, 0/ + data (st0004(iyy),iyy= 1, 8) / 32, 32, 32, 32, 77, 74, 68, 58/ + data (st0004(iyy),iyy= 9,16) / 32, 37, 48, 46, 53,102, 32, 69/ + data (st0004(iyy),iyy=17,24) /112,111, 99,104, 58, 32, 74, 37/ + data (st0004(iyy),iyy=25,32) / 48, 46, 56,102, 32, 66, 37, 48/ + data (st0004(iyy),iyy=33,37) / 46, 56,102, 10, 0/ + data (st0005(iyy),iyy= 1, 8) / 32, 32, 32, 32, 69,113,117,105/ + data (st0005(iyy),iyy= 9,16) /110,111,120, 58, 32, 74, 37, 48/ + data (st0005(iyy),iyy=17,24) / 46, 51,102, 32, 69,112,111, 99/ + data (st0005(iyy),iyy=25,32) /104, 58, 32, 74, 37, 48, 46, 56/ + data (st0005(iyy),iyy=33,40) /102, 32, 77, 74, 68, 58, 32, 37/ + data (st0005(iyy),iyy=41,46) / 48, 46, 53,102, 10, 0/ + data (st0006(iyy),iyy= 1, 8) / 32, 32, 32, 32, 69,113,117,105/ + data (st0006(iyy),iyy= 9,16) /110,111,120, 58, 32, 66, 37, 48/ + data (st0006(iyy),iyy=17,24) / 46, 51,102, 32, 69,112,111, 99/ + data (st0006(iyy),iyy=25,32) /104, 58, 32, 66, 37, 48, 46, 56/ + data (st0006(iyy),iyy=33,40) /102, 32, 77, 74, 68, 58, 32, 37/ + data (st0006(iyy),iyy=41,46) / 48, 46, 53,102, 10, 0/ + data (st0007(iyy),iyy= 1, 8) / 37,115, 58, 32, 37,115, 32, 32/ + data (st0007(iyy),iyy= 9,16) / 67,111,111,114,100,105,110, 97/ + data (st0007(iyy),iyy=17,24) /116,101,115, 58, 32,101, 99,108/ + data (st0007(iyy),iyy=25,31) /105,112,116,105, 99, 10, 0/ + data (st0008(iyy),iyy= 1, 8) / 32, 32, 32, 32, 77, 74, 68, 58/ + data (st0008(iyy),iyy= 9,16) / 32, 37, 48, 46, 53,102, 32, 69/ + data (st0008(iyy),iyy=17,24) /112,111, 99,104, 58, 32, 74, 37/ + data (st0008(iyy),iyy=25,32) / 48, 46, 56,102, 32, 66, 37, 48/ + data (st0008(iyy),iyy=33,37) / 46, 56,102, 10, 0/ + data (st0009(iyy),iyy= 1, 8) / 37,115, 58, 32, 37,115, 32, 32/ + data (st0009(iyy),iyy= 9,16) / 67,111,111,114,100,105,110, 97/ + data (st0009(iyy),iyy=17,24) /116,101,115, 58, 32,103, 97,108/ + data (st0009(iyy),iyy=25,31) / 97, 99,116,105, 99, 10, 0/ + data (st0010(iyy),iyy= 1, 8) / 32, 32, 32, 32, 77, 74, 68, 58/ + data (st0010(iyy),iyy= 9,16) / 32, 37, 48, 46, 53,102, 32, 69/ + data (st0010(iyy),iyy=17,24) /112,111, 99,104, 58, 32, 74, 37/ + data (st0010(iyy),iyy=25,32) / 48, 46, 56,102, 32, 66, 37, 48/ + data (st0010(iyy),iyy=33,37) / 46, 56,102, 10, 0/ + data (st0011(iyy),iyy= 1, 8) / 37,115, 58, 32, 37,115, 32, 32/ + data (st0011(iyy),iyy= 9,16) / 67,111,111,114,100,105,110, 97/ + data (st0011(iyy),iyy=17,24) /116,101,115, 58, 32,115,117,112/ + data (st0011(iyy),iyy=25,32) /101,114,103, 97,108, 97, 99,116/ + data (st0011(iyy),iyy=33,36) /105, 99, 10, 0/ + data (st0012(iyy),iyy= 1, 8) / 32, 32, 32, 32, 77, 74, 68, 58/ + data (st0012(iyy),iyy= 9,16) / 32, 37, 48, 46, 53,102, 32, 69/ + data (st0012(iyy),iyy=17,24) /112,111, 99,104, 58, 32, 74, 37/ + data (st0012(iyy),iyy=25,32) / 48, 46, 56,102, 32, 66, 37, 48/ + data (st0012(iyy),iyy=33,37) / 46, 56,102, 10, 0/ + call smark (sp) + call salloc (radecr, 255 , 2) + sw0001=(ctype) + goto 110 +120 continue + if (.not.(skwrdr (radecs, memc(radecr), 255 , st0001) .le. 0 + * )) goto 130 + call xstrcy(st0002, memc(radecr), 255 ) +130 continue + call strupr (memc(radecr)) + call xprinf(st0003) + call pargsr (label) + call pargsr (system) + call pargsr (memc(radecr)) + sw0002=(radecs) + goto 140 +150 continue + call xprinf(st0004) + call pargd (epoch) + if (.not.(((epoch).eq.1.6d308))) goto 160 + call pargd (1.6d308) + call pargd (1.6d308) + goto 161 +160 continue + call pargd (slepj (epoch)) + call pargd (slepb (epoch)) +161 continue + goto 141 +170 continue + call xprinf(st0005) + call pargd (equinx) + call pargd (slepj(epoch)) + call pargd (epoch) + goto 141 +180 continue + call xprinf(st0006) + call pargd (equinx) + call pargd (slepb(epoch)) + call pargd (epoch) + goto 141 +140 continue + sw0002=sw0002-2 + if (sw0002.lt.1.or.sw0002.gt.3) goto 180 + goto (170,170,150),sw0002 +141 continue + goto 111 +190 continue + call xprinf(st0007) + call pargsr (label) + call pargsr (system) + call xprinf(st0008) + call pargd (epoch) + if (.not.(((epoch).eq.1.6d308))) goto 200 + call pargd (1.6d308) + call pargd (1.6d308) + goto 201 +200 continue + call pargd (slepj(epoch)) + call pargd (slepb(epoch)) +201 continue + goto 111 +210 continue + call xprinf(st0009) + call pargsr (label) + call pargsr (system) + call xprinf(st0010) + call pargd (epoch) + call pargd (slepj (epoch)) + call pargd (slepb (epoch)) + goto 111 +220 continue + call xprinf(st0011) + call pargsr (label) + call pargsr (system) + call xprinf(st0012) + call pargd (epoch) + call pargd (slepj (epoch)) + call pargd (slepb (epoch)) + goto 111 +110 continue + if (sw0001.lt.1.or.sw0001.gt.4) goto 111 + goto (120,190,210,220),sw0001 +111 continue + call sfree (sp) +100 return + end + subroutine skinwe (fd, label, system, ctype, radecs, equinx, epoch + *) + integer fd + integer ctype + integer radecs + double precision equinx + double precision epoch + integer*2 label(*) + integer*2 system(*) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer sp + integer radecr + double precision slepj + double precision slepb + integer skwrdr + integer sw0001,sw0002 + integer*2 st0001(30) + integer*2 st0002(4) + integer*2 st0003(38) + integer*2 st0004(39) + integer*2 st0005(48) + integer*2 st0006(48) + integer*2 st0007(33) + integer*2 st0008(39) + integer*2 st0009(33) + integer*2 st0010(39) + integer*2 st0011(38) + integer*2 st0012(39) + save + integer iyy + data (st0001(iyy),iyy= 1, 8) /124,102,107, 52,124,102,107, 52/ + data (st0001(iyy),iyy= 9,16) / 45,110,111, 45,101,124,102,107/ + data (st0001(iyy),iyy=17,24) / 53,124,105, 99,114,115,124,103/ + data (st0001(iyy),iyy=25,30) / 97,112,112,116,124, 0/ + data st0002 / 70, 75, 53, 0/ + data (st0003(iyy),iyy= 1, 8) / 35, 32, 37,115, 58, 32, 37,115/ + data (st0003(iyy),iyy= 9,16) / 32, 32, 67,111,111,114,100,105/ + data (st0003(iyy),iyy=17,24) /110, 97,116,101,115, 58, 32,101/ + data (st0003(iyy),iyy=25,32) /113,117, 97,116,111,114,105, 97/ + data (st0003(iyy),iyy=33,38) /108, 32, 37,115, 10, 0/ + data (st0004(iyy),iyy= 1, 8) / 35, 32, 32, 32, 32, 32, 77, 74/ + data (st0004(iyy),iyy= 9,16) / 68, 58, 32, 37, 48, 46, 53,102/ + data (st0004(iyy),iyy=17,24) / 32, 69,112,111, 99,104, 58, 32/ + data (st0004(iyy),iyy=25,32) / 74, 37, 48, 46, 56,102, 32, 66/ + data (st0004(iyy),iyy=33,39) / 37, 48, 46, 56,102, 10, 0/ + data (st0005(iyy),iyy= 1, 8) / 35, 32, 32, 32, 32, 32, 69,113/ + data (st0005(iyy),iyy= 9,16) /117,105,110,111,120, 58, 32, 74/ + data (st0005(iyy),iyy=17,24) / 37, 48, 46, 51,102, 32, 69,112/ + data (st0005(iyy),iyy=25,32) /111, 99,104, 58, 32, 74, 37, 48/ + data (st0005(iyy),iyy=33,40) / 46, 56,102, 32, 77, 74, 68, 58/ + data (st0005(iyy),iyy=41,48) / 32, 37, 48, 46, 53,102, 10, 0/ + data (st0006(iyy),iyy= 1, 8) / 35, 32, 32, 32, 32, 32, 69,113/ + data (st0006(iyy),iyy= 9,16) /117,105,110,111,120, 58, 32, 66/ + data (st0006(iyy),iyy=17,24) / 37, 48, 46, 51,102, 32, 69,112/ + data (st0006(iyy),iyy=25,32) /111, 99,104, 58, 32, 66, 37, 48/ + data (st0006(iyy),iyy=33,40) / 46, 56,102, 32, 77, 74, 68, 58/ + data (st0006(iyy),iyy=41,48) / 32, 37, 48, 46, 53,102, 10, 0/ + data (st0007(iyy),iyy= 1, 8) / 35, 32, 37,115, 58, 32, 37,115/ + data (st0007(iyy),iyy= 9,16) / 32, 32, 67,111,111,114,100,105/ + data (st0007(iyy),iyy=17,24) /110, 97,116,101,115, 58, 32,101/ + data (st0007(iyy),iyy=25,32) / 99,108,105,112,116,105, 99, 10/ + data (st0007(iyy),iyy=33,33) / 0/ + data (st0008(iyy),iyy= 1, 8) / 35, 32, 32, 32, 32, 32, 77, 74/ + data (st0008(iyy),iyy= 9,16) / 68, 58, 32, 37, 48, 46, 53,102/ + data (st0008(iyy),iyy=17,24) / 32, 69,112,111, 99,104, 58, 32/ + data (st0008(iyy),iyy=25,32) / 74, 37, 48, 46, 56,102, 32, 66/ + data (st0008(iyy),iyy=33,39) / 37, 48, 46, 56,102, 10, 0/ + data (st0009(iyy),iyy= 1, 8) / 35, 32, 37,115, 58, 32, 37,115/ + data (st0009(iyy),iyy= 9,16) / 32, 32, 67,111,111,114,100,105/ + data (st0009(iyy),iyy=17,24) /110, 97,116,101,115, 58, 32,103/ + data (st0009(iyy),iyy=25,32) / 97,108, 97, 99,116,105, 99, 10/ + data (st0009(iyy),iyy=33,33) / 0/ + data (st0010(iyy),iyy= 1, 8) / 35, 32, 32, 32, 32, 32, 77, 74/ + data (st0010(iyy),iyy= 9,16) / 68, 58, 32, 37, 48, 46, 53,102/ + data (st0010(iyy),iyy=17,24) / 32, 69,112,111, 99,104, 58, 32/ + data (st0010(iyy),iyy=25,32) / 74, 37, 48, 46, 56,102, 32, 66/ + data (st0010(iyy),iyy=33,39) / 37, 48, 46, 56,102, 10, 0/ + data (st0011(iyy),iyy= 1, 8) / 35, 32, 37,115, 58, 32, 37,115/ + data (st0011(iyy),iyy= 9,16) / 32, 32, 67,111,111,114,100,105/ + data (st0011(iyy),iyy=17,24) /110, 97,116,101,115, 58, 32,115/ + data (st0011(iyy),iyy=25,32) /117,112,101,114,103, 97,108, 97/ + data (st0011(iyy),iyy=33,38) / 99,116,105, 99, 10, 0/ + data (st0012(iyy),iyy= 1, 8) / 35, 32, 32, 32, 32, 32, 77, 74/ + data (st0012(iyy),iyy= 9,16) / 68, 58, 32, 37, 48, 46, 53,102/ + data (st0012(iyy),iyy=17,24) / 32, 69,112,111, 99,104, 58, 32/ + data (st0012(iyy),iyy=25,32) / 74, 37, 48, 46, 56,102, 32, 66/ + data (st0012(iyy),iyy=33,39) / 37, 48, 46, 56,102, 10, 0/ + call smark (sp) + call salloc (radecr, 255 , 2) + sw0001=(ctype) + goto 110 +120 continue + if (.not.(skwrdr (radecs, memc(radecr), 255 , st0001) .le. 0 + * )) goto 130 + call xstrcy(st0002, memc(radecr), 255 ) +130 continue + call strupr (memc(radecr)) + call fprinf (fd, st0003) + call pargsr (label) + call pargsr (system) + call pargsr (memc(radecr)) + sw0002=(radecs) + goto 140 +150 continue + call fprinf (fd, st0004) + call pargd (epoch) + if (.not.(((epoch).eq.1.6d308))) goto 160 + call pargd (1.6d308) + call pargd (1.6d308) + goto 161 +160 continue + call pargd (slepj(epoch)) + call pargd (slepb(epoch)) +161 continue + goto 141 +170 continue + call fprinf (fd, st0005) + call pargd (equinx) + call pargd (slepj(epoch)) + call pargd (epoch) + goto 141 +180 continue + call fprinf (fd, st0006) + call pargd (equinx) + call pargd (slepb(epoch)) + call pargd (epoch) + goto 141 +140 continue + sw0002=sw0002-2 + if (sw0002.lt.1.or.sw0002.gt.3) goto 180 + goto (170,170,150),sw0002 +141 continue + goto 111 +190 continue + call fprinf (fd, st0007) + call pargsr (label) + call pargsr (system) + call fprinf (fd, st0008) + call pargd (epoch) + if (.not.(((epoch).eq.1.6d308))) goto 200 + call pargd (1.6d308) + call pargd (1.6d308) + goto 201 +200 continue + call pargd (slepj(epoch)) + call pargd (slepb(epoch)) +201 continue + goto 111 +210 continue + call fprinf (fd, st0009) + call pargsr (label) + call pargsr (system) + call fprinf (fd, st0010) + call pargd (epoch) + call pargd (slepj(epoch)) + call pargd (slepb(epoch)) + goto 111 +220 continue + call fprinf (fd, st0011) + call pargsr (label) + call pargsr (system) + call fprinf (fd, st0012) + call pargd (epoch) + call pargd (slepj(epoch)) + call pargd (slepb(epoch)) + goto 111 +110 continue + if (sw0001.lt.1.or.sw0001.gt.4) goto 111 + goto (120,190,210,220),sw0001 +111 continue + call sfree (sp) +100 return + end + subroutine skimpt (label, images, ctype, lngax, latax, wtype, + *ptype, radecs, equinx, epoch) + integer ctype + integer lngax + integer latax + integer wtype + integer ptype + integer radecs + double precision equinx + double precision epoch + integer*2 label(*) + integer*2 images(*) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer sp + integer imname + integer projsr + integer wcsstr + integer radecr + double precision slepj + double precision slepb + integer skwrdr + integer sw0001,sw0002 + integer*2 st0001(114) + integer*2 st0002(7) + integer*2 st0003(28) + integer*2 st0004(6) + integer*2 st0005(30) + integer*2 st0006(4) + integer*2 st0007(47) + integer*2 st0008(32) + integer*2 st0009(37) + integer*2 st0010(48) + integer*2 st0011(30) + integer*2 st0012(48) + integer*2 st0013(30) + integer*2 st0014(51) + integer*2 st0015(27) + integer*2 st0016(37) + integer*2 st0017(51) + integer*2 st0018(27) + integer*2 st0019(38) + integer*2 st0020(51) + integer*2 st0021(32) + integer*2 st0022(37) + save + integer iyy + data (st0001(iyy),iyy= 1, 8) /124,108,105,110,124, 97,122,112/ + data (st0001(iyy),iyy= 9,16) /124,116, 97,110,124,115,105,110/ + data (st0001(iyy),iyy=17,24) /124,115,116,103,124, 97,114, 99/ + data (st0001(iyy),iyy=25,32) /124,122,112,110,124,122,101, 97/ + data (st0001(iyy),iyy=33,40) /124, 97,105,114,124, 99,121,112/ + data (st0001(iyy),iyy=41,48) /124, 99, 97,114,124,109,101,114/ + data (st0001(iyy),iyy=49,56) /124, 99,101, 97,124, 99,111,112/ + data (st0001(iyy),iyy=57,64) /124, 99,111,100,124, 99,111,101/ + data (st0001(iyy),iyy=65,72) /124, 99,111,111,124, 98,111,110/ + data (st0001(iyy),iyy=73,80) /124,112, 99,111,124,103,108,115/ + data (st0001(iyy),iyy=81,88) /124,112, 97,114,124, 97,105,116/ + data (st0001(iyy),iyy=89,96) /124,109,111,108,124, 99,115, 99/ + data (st0001(iyy),iyy=97,104) /124,113,115, 99,124,116,115, 99/ + data (st0001(iyy),iyy=105,112) /124,116,110,120,124,122,112,120/ + data (st0001(iyy),iyy=113,114) /124, 0/ + data st0002 /108,105,110,101, 97,114, 0/ + data (st0003(iyy),iyy= 1, 8) /124,108,111,103,105, 99, 97,108/ + data (st0003(iyy),iyy= 9,16) /124,116,118,124,112,104,121,115/ + data (st0003(iyy),iyy=17,24) /105, 99, 97,108,124,119,111,114/ + data (st0003(iyy),iyy=25,28) /108,100,124, 0/ + data st0004 /119,111,114,108,100, 0/ + data (st0005(iyy),iyy= 1, 8) /124,102,107, 52,124,102,107, 52/ + data (st0005(iyy),iyy= 9,16) / 45,110,111, 45,101,124,102,107/ + data (st0005(iyy),iyy=17,24) / 53,124,105, 99,114,115,124,103/ + data (st0005(iyy),iyy=25,30) / 97,112,112,116,124, 0/ + data st0006 / 70, 75, 53, 0/ + data (st0007(iyy),iyy= 1, 8) / 37,115, 58, 32, 37,115, 32, 37/ + data (st0007(iyy),iyy= 9,16) /115, 32, 32, 80,114,111,106,101/ + data (st0007(iyy),iyy=17,24) / 99,116,105,111,110, 58, 32, 37/ + data (st0007(iyy),iyy=25,32) /115, 32, 32, 82, 97, 47, 68,101/ + data (st0007(iyy),iyy=33,40) / 99, 32, 97,120,101,115, 58, 32/ + data (st0007(iyy),iyy=41,47) / 37,100, 47, 37,100, 10, 0/ + data (st0008(iyy),iyy= 1, 8) / 32, 32, 32, 32, 67,111,111,114/ + data (st0008(iyy),iyy= 9,16) /100,105,110, 97,116,101,115, 58/ + data (st0008(iyy),iyy=17,24) / 32,101,113,117, 97,116,111,114/ + data (st0008(iyy),iyy=25,32) /105, 97,108, 32, 37,115, 10, 0/ + data (st0009(iyy),iyy= 1, 8) / 32, 32, 32, 32, 77, 74, 68, 58/ + data (st0009(iyy),iyy= 9,16) / 32, 37, 48, 46, 53,102, 32, 69/ + data (st0009(iyy),iyy=17,24) /112,111, 99,104, 58, 32, 74, 37/ + data (st0009(iyy),iyy=25,32) / 48, 46, 56,102, 32, 66, 37, 48/ + data (st0009(iyy),iyy=33,37) / 46, 56,102, 10, 0/ + data (st0010(iyy),iyy= 1, 8) / 32, 32, 32, 32, 67,111,111,114/ + data (st0010(iyy),iyy= 9,16) /100,105,110, 97,116,101,115, 58/ + data (st0010(iyy),iyy=17,24) / 32,101,113,117, 97,116,111,114/ + data (st0010(iyy),iyy=25,32) /105, 97,108, 32, 37,115, 32, 69/ + data (st0010(iyy),iyy=33,40) /113,117,105,110,111,120, 58, 32/ + data (st0010(iyy),iyy=41,48) / 74, 37, 48, 46, 51,102, 10, 0/ + data (st0011(iyy),iyy= 1, 8) / 32, 32, 32, 32, 69,112,111, 99/ + data (st0011(iyy),iyy= 9,16) /104, 58, 32, 74, 37, 48, 46, 56/ + data (st0011(iyy),iyy=17,24) /102, 32, 77, 74, 68, 58, 32, 37/ + data (st0011(iyy),iyy=25,30) / 48, 46, 53,102, 10, 0/ + data (st0012(iyy),iyy= 1, 8) / 32, 32, 32, 32, 67,111,111,114/ + data (st0012(iyy),iyy= 9,16) /100,105,110, 97,116,101,115, 58/ + data (st0012(iyy),iyy=17,24) / 32,101,113,117, 97,116,111,114/ + data (st0012(iyy),iyy=25,32) /105, 97,108, 32, 37,115, 32, 69/ + data (st0012(iyy),iyy=33,40) /113,117,105,110,111,120, 58, 32/ + data (st0012(iyy),iyy=41,48) / 66, 37, 48, 46, 51,102, 10, 0/ + data (st0013(iyy),iyy= 1, 8) / 32, 32, 32, 32, 69,112,111, 99/ + data (st0013(iyy),iyy= 9,16) /104, 58, 32, 66, 37, 48, 46, 56/ + data (st0013(iyy),iyy=17,24) /102, 32, 77, 74, 68, 58, 32, 37/ + data (st0013(iyy),iyy=25,30) / 48, 46, 53,102, 10, 0/ + data (st0014(iyy),iyy= 1, 8) / 37,115, 58, 32, 37,115, 32, 37/ + data (st0014(iyy),iyy= 9,16) /115, 32, 32, 80,114,111,106,101/ + data (st0014(iyy),iyy=17,24) / 99,116,105,111,110, 58, 32, 37/ + data (st0014(iyy),iyy=25,32) /115, 32, 32, 69,108,111,110,103/ + data (st0014(iyy),iyy=33,40) / 47, 69,108, 97,116, 32, 97,120/ + data (st0014(iyy),iyy=41,48) /101,115, 58, 32, 37,100, 47, 37/ + data (st0014(iyy),iyy=49,51) /100, 10, 0/ + data (st0015(iyy),iyy= 1, 8) / 32, 32, 32, 32, 67,111,111,114/ + data (st0015(iyy),iyy= 9,16) /100,105,110, 97,116,101,115, 58/ + data (st0015(iyy),iyy=17,24) / 32,101, 99,108,105,112,116,105/ + data (st0015(iyy),iyy=25,27) / 99, 10, 0/ + data (st0016(iyy),iyy= 1, 8) / 32, 32, 32, 32, 77, 74, 68, 58/ + data (st0016(iyy),iyy= 9,16) / 32, 37, 48, 46, 53,102, 32, 69/ + data (st0016(iyy),iyy=17,24) /112,111, 99,104, 58, 32, 74, 37/ + data (st0016(iyy),iyy=25,32) / 48, 46, 56,102, 32, 66, 37, 48/ + data (st0016(iyy),iyy=33,37) / 46, 56,102, 10, 0/ + data (st0017(iyy),iyy= 1, 8) / 37,115, 58, 32, 37,115, 32, 37/ + data (st0017(iyy),iyy= 9,16) /115, 32, 32, 80,114,111,106,101/ + data (st0017(iyy),iyy=17,24) / 99,116,105,111,110, 58, 32, 37/ + data (st0017(iyy),iyy=25,32) /115, 32, 32, 71,108,111,110,103/ + data (st0017(iyy),iyy=33,40) / 47, 71,108, 97,116, 32, 97,120/ + data (st0017(iyy),iyy=41,48) /101,115, 58, 32, 37,100, 47, 37/ + data (st0017(iyy),iyy=49,51) /100, 10, 0/ + data (st0018(iyy),iyy= 1, 8) / 32, 32, 32, 32, 67,111,111,114/ + data (st0018(iyy),iyy= 9,16) /100,105,110, 97,116,101,115, 58/ + data (st0018(iyy),iyy=17,24) / 32,103, 97,108, 97, 99,116,105/ + data (st0018(iyy),iyy=25,27) / 99, 10, 0/ + data (st0019(iyy),iyy= 1, 8) / 32, 32, 32, 32, 77, 74, 68, 58/ + data (st0019(iyy),iyy= 9,16) / 32, 37, 48, 46, 53,102, 32, 32/ + data (st0019(iyy),iyy=17,24) / 69,112,111, 99,104, 58, 32, 74/ + data (st0019(iyy),iyy=25,32) / 37, 48, 46, 56,102, 32, 66, 37/ + data (st0019(iyy),iyy=33,38) / 48, 46, 56,102, 10, 0/ + data (st0020(iyy),iyy= 1, 8) / 37,115, 58, 32, 37,115, 32, 37/ + data (st0020(iyy),iyy= 9,16) /115, 32, 32, 80,114,111,106,101/ + data (st0020(iyy),iyy=17,24) / 99,116,105,111,110, 58, 32, 37/ + data (st0020(iyy),iyy=25,32) /115, 32, 32, 83,108,111,110,103/ + data (st0020(iyy),iyy=33,40) / 47, 83,108, 97,116, 32, 97,120/ + data (st0020(iyy),iyy=41,48) /101,115, 58, 32, 37,100, 47, 37/ + data (st0020(iyy),iyy=49,51) /100, 10, 0/ + data (st0021(iyy),iyy= 1, 8) / 32, 32, 32, 32, 67,111,111,114/ + data (st0021(iyy),iyy= 9,16) /100,105,110, 97,116,101,115, 58/ + data (st0021(iyy),iyy=17,24) / 32,115,117,112,101,114,103, 97/ + data (st0021(iyy),iyy=25,32) /108, 97, 99,116,105, 99, 10, 0/ + data (st0022(iyy),iyy= 1, 8) / 32, 32, 32, 32, 77, 74, 68, 58/ + data (st0022(iyy),iyy= 9,16) / 32, 37, 48, 46, 53,102, 32, 69/ + data (st0022(iyy),iyy=17,24) /112,111, 99,104, 58, 32, 74, 37/ + data (st0022(iyy),iyy=25,32) / 48, 46, 56,102, 32, 66, 37, 48/ + data (st0022(iyy),iyy=33,37) / 46, 56,102, 10, 0/ + call smark (sp) + call salloc (imname, 255 , 2) + call salloc (projsr, 255 , 2) + call salloc (wcsstr, 255 , 2) + call salloc (radecr, 255 , 2) + call sscan (images) + call gargwd (memc(imname), 255 ) + if (.not.(skwrdr (wtype, memc(projsr), 255 , st0001) .le. 0)) + * goto 110 + call xstrcy(st0002, memc(projsr), 255 ) +110 continue + call strupr (memc(projsr)) + if (.not.(skwrdr (ptype, memc(wcsstr), 255 , st0003) .le. 0)) + * goto 120 + call xstrcy(st0004, memc(wcsstr), 255 ) +120 continue + call strlwr (memc(wcsstr)) + sw0001=(ctype) + goto 130 +140 continue + if (.not.(skwrdr (radecs, memc(radecr), 255 , st0005) .le. 0 + * )) goto 150 + call xstrcy(st0006, memc(radecr), 255 ) +150 continue + call strupr (memc(radecr)) + call xprinf( st0007) + call pargsr (label) + call pargsr (memc(imname)) + call pargsr (memc(wcsstr)) + call pargsr (memc(projsr)) + call pargi (lngax) + call pargi (latax) + sw0002=(radecs) + goto 160 +170 continue + call xprinf(st0008) + call pargsr (memc(radecr)) + call xprinf(st0009) + call pargd (epoch) + if (.not.(((epoch).eq.1.6d308))) goto 180 + call pargd (1.6d308) + call pargd (1.6d308) + goto 181 +180 continue + call pargd (slepj(epoch)) + call pargd (slepb(epoch)) +181 continue + goto 161 +190 continue + call xprinf(st0010) + call pargsr (memc(radecr)) + call pargd (equinx) + call xprinf(st0011) + call pargd (slepj (epoch)) + call pargd (epoch) + goto 161 +200 continue + call xprinf(st0012) + call pargsr (memc(radecr)) + call pargd (equinx) + call xprinf(st0013) + call pargd (slepb (epoch)) + call pargd (epoch) + goto 161 +160 continue + sw0002=sw0002-2 + if (sw0002.lt.1.or.sw0002.gt.3) goto 200 + goto (190,190,170),sw0002 +161 continue + goto 131 +210 continue + call xprinf( st0014) + call pargsr (label) + call pargsr (memc(imname)) + call pargsr (memc(wcsstr)) + call pargsr (memc(projsr)) + call pargi (lngax) + call pargi (latax) + call xprinf(st0015) + call xprinf(st0016) + call pargd (epoch) + if (.not.(((epoch).eq.1.6d308))) goto 220 + call pargd (1.6d308) + call pargd (1.6d308) + goto 221 +220 continue + call pargd (slepj(epoch)) + call pargd (slepb(epoch)) +221 continue + goto 131 +230 continue + call xprinf( st0017) + call pargsr (label) + call pargsr (memc(imname)) + call pargsr (memc(wcsstr)) + call pargsr (memc(projsr)) + call pargi (lngax) + call pargi (latax) + call xprinf(st0018) + call xprinf(st0019) + call pargd (epoch) + call pargd (slepj (epoch)) + call pargd (slepb (epoch)) + goto 131 +240 continue + call xprinf( st0020) + call pargsr (label) + call pargsr (memc(imname)) + call pargsr (memc(wcsstr)) + call pargsr (memc(projsr)) + call pargi (lngax) + call pargi (latax) + call xprinf(st0021) + call xprinf(st0022) + call pargd (epoch) + call pargd (slepj (epoch)) + call pargd (slepb (epoch)) + goto 131 +130 continue + if (sw0001.lt.1.or.sw0001.gt.4) goto 131 + goto (140,210,230,240),sw0001 +131 continue + call sfree (sp) +100 return + end + subroutine skimwe (fd, label, images, ctype, lngax, latax, wtype, + *ptype, radecs, equinx, epoch) + integer fd + integer ctype + integer lngax + integer latax + integer wtype + integer ptype + integer radecs + double precision equinx + double precision epoch + integer*2 label(*) + integer*2 images(*) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer sp + integer imname + integer projsr + integer wcsstr + integer radecr + double precision slepj + double precision slepb + integer skwrdr + integer sw0001,sw0002 + integer*2 st0001(114) + integer*2 st0002(7) + integer*2 st0003(28) + integer*2 st0004(6) + integer*2 st0005(30) + integer*2 st0006(4) + integer*2 st0007(49) + integer*2 st0008(34) + integer*2 st0009(39) + integer*2 st0010(50) + integer*2 st0011(32) + integer*2 st0012(50) + integer*2 st0013(32) + integer*2 st0014(53) + integer*2 st0015(29) + integer*2 st0016(40) + integer*2 st0017(53) + integer*2 st0018(29) + integer*2 st0019(39) + integer*2 st0020(53) + integer*2 st0021(34) + integer*2 st0022(39) + save + integer iyy + data (st0001(iyy),iyy= 1, 8) /124,108,105,110,124, 97,122,112/ + data (st0001(iyy),iyy= 9,16) /124,116, 97,110,124,115,105,110/ + data (st0001(iyy),iyy=17,24) /124,115,116,103,124, 97,114, 99/ + data (st0001(iyy),iyy=25,32) /124,122,112,110,124,122,101, 97/ + data (st0001(iyy),iyy=33,40) /124, 97,105,114,124, 99,121,112/ + data (st0001(iyy),iyy=41,48) /124, 99, 97,114,124,109,101,114/ + data (st0001(iyy),iyy=49,56) /124, 99,101, 97,124, 99,111,112/ + data (st0001(iyy),iyy=57,64) /124, 99,111,100,124, 99,111,101/ + data (st0001(iyy),iyy=65,72) /124, 99,111,111,124, 98,111,110/ + data (st0001(iyy),iyy=73,80) /124,112, 99,111,124,103,108,115/ + data (st0001(iyy),iyy=81,88) /124,112, 97,114,124, 97,105,116/ + data (st0001(iyy),iyy=89,96) /124,109,111,108,124, 99,115, 99/ + data (st0001(iyy),iyy=97,104) /124,113,115, 99,124,116,115, 99/ + data (st0001(iyy),iyy=105,112) /124,116,110,120,124,122,112,120/ + data (st0001(iyy),iyy=113,114) /124, 0/ + data st0002 /108,105,110,101, 97,114, 0/ + data (st0003(iyy),iyy= 1, 8) /124,108,111,103,105, 99, 97,108/ + data (st0003(iyy),iyy= 9,16) /124,116,118,124,112,104,121,115/ + data (st0003(iyy),iyy=17,24) /105, 99, 97,108,124,119,111,114/ + data (st0003(iyy),iyy=25,28) /108,100,124, 0/ + data st0004 /119,111,114,108,100, 0/ + data (st0005(iyy),iyy= 1, 8) /124,102,107, 52,124,102,107, 52/ + data (st0005(iyy),iyy= 9,16) / 45,110,111, 45,101,124,102,107/ + data (st0005(iyy),iyy=17,24) / 53,124,105, 99,114,115,124,103/ + data (st0005(iyy),iyy=25,30) / 97,112,112,116,124, 0/ + data st0006 / 70, 75, 53, 0/ + data (st0007(iyy),iyy= 1, 8) / 35, 32, 37,115, 58, 32, 37,115/ + data (st0007(iyy),iyy= 9,16) / 32, 37,115, 32, 32, 80,114,111/ + data (st0007(iyy),iyy=17,24) /106,101, 99,116,105,111,110, 58/ + data (st0007(iyy),iyy=25,32) / 32, 37,115, 32, 32, 82, 97, 47/ + data (st0007(iyy),iyy=33,40) / 68,101, 99, 32, 97,120,101,115/ + data (st0007(iyy),iyy=41,48) / 58, 32, 37,100, 47, 37,100, 10/ + data (st0007(iyy),iyy=49,49) / 0/ + data (st0008(iyy),iyy= 1, 8) / 35, 32, 32, 32, 32, 32, 67,111/ + data (st0008(iyy),iyy= 9,16) /111,114,100,105,110, 97,116,101/ + data (st0008(iyy),iyy=17,24) /115, 58, 32,101,113,117, 97,116/ + data (st0008(iyy),iyy=25,32) /111,114,105, 97,108, 32, 37,115/ + data (st0008(iyy),iyy=33,34) / 10, 0/ + data (st0009(iyy),iyy= 1, 8) / 35, 32, 32, 32, 32, 32, 77, 74/ + data (st0009(iyy),iyy= 9,16) / 68, 58, 32, 37, 48, 46, 53,102/ + data (st0009(iyy),iyy=17,24) / 32, 69,112,111, 99,104, 58, 32/ + data (st0009(iyy),iyy=25,32) / 74, 37, 48, 46, 56,102, 32, 66/ + data (st0009(iyy),iyy=33,39) / 37, 48, 46, 56,102, 10, 0/ + data (st0010(iyy),iyy= 1, 8) / 35, 32, 32, 32, 32, 32, 67,111/ + data (st0010(iyy),iyy= 9,16) /111,114,100,105,110, 97,116,101/ + data (st0010(iyy),iyy=17,24) /115, 58, 32,101,113,117, 97,116/ + data (st0010(iyy),iyy=25,32) /111,114,105, 97,108, 32, 37,115/ + data (st0010(iyy),iyy=33,40) / 32, 69,113,117,105,110,111,120/ + data (st0010(iyy),iyy=41,48) / 58, 32, 74, 37, 48, 46, 51,102/ + data (st0010(iyy),iyy=49,50) / 10, 0/ + data (st0011(iyy),iyy= 1, 8) / 35, 32, 32, 32, 32, 32, 69,112/ + data (st0011(iyy),iyy= 9,16) /111, 99,104, 58, 32, 74, 37, 48/ + data (st0011(iyy),iyy=17,24) / 46, 56,102, 32, 77, 74, 68, 58/ + data (st0011(iyy),iyy=25,32) / 32, 37, 48, 46, 53,102, 10, 0/ + data (st0012(iyy),iyy= 1, 8) / 35, 32, 32, 32, 32, 32, 67,111/ + data (st0012(iyy),iyy= 9,16) /111,114,100,105,110, 97,116,101/ + data (st0012(iyy),iyy=17,24) /115, 58, 32,101,113,117, 97,116/ + data (st0012(iyy),iyy=25,32) /111,114,105, 97,108, 32, 37,115/ + data (st0012(iyy),iyy=33,40) / 32, 69,113,117,105,110,111,120/ + data (st0012(iyy),iyy=41,48) / 58, 32, 66, 37, 48, 46, 51,102/ + data (st0012(iyy),iyy=49,50) / 10, 0/ + data (st0013(iyy),iyy= 1, 8) / 35, 32, 32, 32, 32, 32, 69,112/ + data (st0013(iyy),iyy= 9,16) /111, 99,104, 58, 32, 66, 37, 48/ + data (st0013(iyy),iyy=17,24) / 46, 56,102, 32, 77, 74, 68, 58/ + data (st0013(iyy),iyy=25,32) / 32, 37, 48, 46, 53,102, 10, 0/ + data (st0014(iyy),iyy= 1, 8) / 35, 32, 37,115, 58, 32, 37,115/ + data (st0014(iyy),iyy= 9,16) / 32, 37,115, 32, 32, 80,114,111/ + data (st0014(iyy),iyy=17,24) /106,101, 99,116,105,111,110, 58/ + data (st0014(iyy),iyy=25,32) / 32, 37,115, 32, 32, 69,108,111/ + data (st0014(iyy),iyy=33,40) /110,103, 47, 69,108, 97,116, 32/ + data (st0014(iyy),iyy=41,48) / 97,120,101,115, 58, 32, 37,100/ + data (st0014(iyy),iyy=49,53) / 47, 37,100, 10, 0/ + data (st0015(iyy),iyy= 1, 8) / 35, 32, 32, 32, 32, 32, 67,111/ + data (st0015(iyy),iyy= 9,16) /111,114,100,105,110, 97,116,101/ + data (st0015(iyy),iyy=17,24) /115, 58, 32,101, 99,108,105,112/ + data (st0015(iyy),iyy=25,29) /116,105, 99, 10, 0/ + data (st0016(iyy),iyy= 1, 8) / 35, 32, 32, 32, 32, 32, 77, 74/ + data (st0016(iyy),iyy= 9,16) / 68, 58, 32, 37, 48, 46, 53,102/ + data (st0016(iyy),iyy=17,24) / 32, 32, 69,112,111, 99,104, 58/ + data (st0016(iyy),iyy=25,32) / 32, 74, 37, 48, 46, 56,102, 32/ + data (st0016(iyy),iyy=33,40) / 66, 37, 48, 46, 56,102, 10, 0/ + data (st0017(iyy),iyy= 1, 8) / 35, 32, 37,115, 58, 32, 37,115/ + data (st0017(iyy),iyy= 9,16) / 32, 37,115, 32, 32, 80,114,111/ + data (st0017(iyy),iyy=17,24) /106,101, 99,116,105,111,110, 58/ + data (st0017(iyy),iyy=25,32) / 32, 37,115, 32, 32, 71,108,111/ + data (st0017(iyy),iyy=33,40) /110,103, 47, 71,108, 97,116, 32/ + data (st0017(iyy),iyy=41,48) / 97,120,101,115, 58, 32, 37,100/ + data (st0017(iyy),iyy=49,53) / 47, 37,100, 10, 0/ + data (st0018(iyy),iyy= 1, 8) / 35, 32, 32, 32, 32, 32, 67,111/ + data (st0018(iyy),iyy= 9,16) /111,114,100,105,110, 97,116,101/ + data (st0018(iyy),iyy=17,24) /115, 58, 32,103, 97,108, 97, 99/ + data (st0018(iyy),iyy=25,29) /116,105, 99, 10, 0/ + data (st0019(iyy),iyy= 1, 8) / 35, 32, 32, 32, 32, 32, 77, 74/ + data (st0019(iyy),iyy= 9,16) / 68, 58, 32, 37, 48, 46, 53,102/ + data (st0019(iyy),iyy=17,24) / 32, 69,112,111, 99,104, 58, 32/ + data (st0019(iyy),iyy=25,32) / 74, 37, 48, 46, 56,102, 32, 66/ + data (st0019(iyy),iyy=33,39) / 37, 48, 46, 56,102, 10, 0/ + data (st0020(iyy),iyy= 1, 8) / 35, 32, 37,115, 58, 32, 37,115/ + data (st0020(iyy),iyy= 9,16) / 32, 37,115, 32, 32, 80,114,111/ + data (st0020(iyy),iyy=17,24) /106,101, 99,116,105,111,110, 58/ + data (st0020(iyy),iyy=25,32) / 32, 37,115, 32, 32, 83,108,111/ + data (st0020(iyy),iyy=33,40) /110,103, 47, 83,108, 97,116, 32/ + data (st0020(iyy),iyy=41,48) / 97,120,101,115, 58, 32, 37,100/ + data (st0020(iyy),iyy=49,53) / 47, 37,100, 10, 0/ + data (st0021(iyy),iyy= 1, 8) / 35, 32, 32, 32, 32, 32, 67,111/ + data (st0021(iyy),iyy= 9,16) /111,114,100,105,110, 97,116,101/ + data (st0021(iyy),iyy=17,24) /115, 58, 32,115,117,112,101,114/ + data (st0021(iyy),iyy=25,32) /103, 97,108, 97, 99,116,105, 99/ + data (st0021(iyy),iyy=33,34) / 10, 0/ + data (st0022(iyy),iyy= 1, 8) / 35, 32, 32, 32, 32, 32, 77, 74/ + data (st0022(iyy),iyy= 9,16) / 68, 58, 32, 37, 48, 46, 53,102/ + data (st0022(iyy),iyy=17,24) / 32, 69,112,111, 99,104, 58, 32/ + data (st0022(iyy),iyy=25,32) / 74, 37, 48, 46, 56,102, 32, 66/ + data (st0022(iyy),iyy=33,39) / 37, 48, 46, 56,102, 10, 0/ + call smark (sp) + call salloc (imname, 255 , 2) + call salloc (projsr, 255 , 2) + call salloc (wcsstr, 255 , 2) + call salloc (radecr, 255 , 2) + call sscan (images) + call gargwd (memc(imname), 255 ) + if (.not.(skwrdr (wtype, memc(projsr), 255 , st0001) .le. 0)) + * goto 110 + call xstrcy(st0002, memc(projsr), 255 ) +110 continue + call strupr (memc(projsr)) + if (.not.(skwrdr (ptype, memc(wcsstr), 255 , st0003) .le. 0)) + * goto 120 + call xstrcy(st0004, memc(wcsstr), 255 ) +120 continue + call strlwr (memc(wcsstr)) + sw0001=(ctype) + goto 130 +140 continue + if (.not.(skwrdr (radecs, memc(radecr), 255 , st0005) .le. 0 + * )) goto 150 + call xstrcy(st0006, memc(radecr), 255 ) +150 continue + call strupr (memc(radecr)) + call fprinf (fd, st0007) + call pargsr (label) + call pargsr (memc(imname)) + call pargsr (memc(wcsstr)) + call pargsr (memc(projsr)) + call pargi (lngax) + call pargi (latax) + sw0002=(radecs) + goto 160 +170 continue + call fprinf (fd, st0008) + call pargsr (memc(radecr)) + call fprinf (fd, st0009) + call pargd (epoch) + if (.not.(((epoch).eq.1.6d308))) goto 180 + call pargd (1.6d308) + call pargd (1.6d308) + goto 181 +180 continue + call pargd (slepj(epoch)) + call pargd (slepb(epoch)) +181 continue + goto 161 +190 continue + call fprinf (fd, st0010) + call pargsr (memc(radecr)) + call pargd (equinx) + call fprinf (fd, st0011) + call pargd (slepj(epoch)) + call pargd (epoch) + goto 161 +200 continue + call fprinf (fd, st0012) + call pargsr (memc(radecr)) + call pargd (equinx) + call fprinf (fd, st0013) + call pargd (slepb (epoch)) + call pargd (epoch) + goto 161 +160 continue + sw0002=sw0002-2 + if (sw0002.lt.1.or.sw0002.gt.3) goto 200 + goto (190,190,170),sw0002 +161 continue + goto 131 +210 continue + call fprinf (fd, st0014) + call pargsr (label) + call pargsr (memc(imname)) + call pargsr (memc(wcsstr)) + call pargsr (memc(projsr)) + call pargi (lngax) + call pargi (latax) + call fprinf (fd, st0015) + call fprinf (fd, st0016) + call pargd (epoch) + if (.not.(((epoch).eq.1.6d308))) goto 220 + call pargd (1.6d308) + call pargd (1.6d308) + goto 221 +220 continue + call pargd (slepj(epoch)) + call pargd (slepb(epoch)) +221 continue + goto 131 +230 continue + call fprinf (fd, st0017) + call pargsr (label) + call pargsr (memc(imname)) + call pargsr (memc(wcsstr)) + call pargsr (memc(projsr)) + call pargi (lngax) + call pargi (latax) + call fprinf (fd, st0018) + call fprinf (fd, st0019) + call pargd (epoch) + call pargd (slepj(epoch)) + call pargd (slepb(epoch)) + goto 131 +240 continue + call fprinf (fd, st0020) + call pargsr (label) + call pargsr (memc(imname)) + call pargsr (memc(wcsstr)) + call pargsr (memc(projsr)) + call pargi (lngax) + call pargi (latax) + call fprinf (fd, st0021) + call fprinf (fd, st0022) + call pargd (epoch) + call pargd (slepj(epoch)) + call pargd (slepb(epoch)) + goto 131 +130 continue + if (sw0001.lt.1.or.sw0001.gt.4) goto 131 + goto (140,210,230,240),sw0001 +131 continue + call sfree (sp) +100 return + end +c radecs radecsys +c equinx equinox +c images imagesys +c skwrdr sk_wrdstr +c skiiwe sk_iiwrite +c skiipt sk_iiprint +c skimwe sk_imwrite +c skinwe sk_inwrite +c skimpt sk_imprint +c skinpt sk_inprint +c projsr projstr +c gargwd gargwrd +c fprinf fprintf +c radecr radecstr +c pargsr pargstr diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skwrite.x b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skwrite.x new file mode 100644 index 00000000..2e779b09 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skwrite.x @@ -0,0 +1,510 @@ +include "skywcsdef.h" +include "skywcs.h" + + +# SK_IIPRINT -- Print a summary of the input image or list coordinate system. + +procedure sk_iiprint (label, imagesys, mw, coo) + +char label[ARB] #I the input label +char imagesys[ARB] #I the input image name and wcs +pointer mw #I pointer to the image wcs +pointer coo #I pointer to the coordinate system structure + +begin + if (mw == NULL) + call sk_inprint (label, imagesys, SKY_CTYPE(coo), + SKY_RADECSYS(coo), SKY_EQUINOX(coo), SKY_EPOCH(coo)) + else + call sk_imprint (label, imagesys, SKY_CTYPE(coo), SKY_PLNGAX(coo), + SKY_PLATAX(coo), SKY_WTYPE(coo), SKY_PIXTYPE(coo), + SKY_RADECSYS(coo), SKY_EQUINOX(coo), SKY_EPOCH(coo)) +end + + +# SK_IIWRITE -- Write a summary of the input image or list coordinate system +# to the output file + +procedure sk_iiwrite (fd, label, imagesys, mw, coo) + +int fd #I the output file descriptor +char label[ARB] #I the input label +char imagesys[ARB] #I the input image name and wcs +pointer mw #I pointer to the image wcs +pointer coo #I pointer to the coordinate system structure + +begin + if (mw == NULL) + call sk_inwrite (fd, label, imagesys, SKY_CTYPE(coo), + SKY_RADECSYS(coo), SKY_EQUINOX(coo), SKY_EPOCH(coo)) + else + call sk_imwrite (fd, label, imagesys, SKY_CTYPE(coo), + SKY_PLNGAX(coo), SKY_PLATAX(coo), SKY_WTYPE(coo), + SKY_PIXTYPE(coo), SKY_RADECSYS(coo), SKY_EQUINOX(coo), + SKY_EPOCH(coo)) +end + + +# SK_INPRINT -- Print a summary of the input list coordinate system. +# This should probably be a call to sk_inwrite with the file descriptor +# set to STDOUT to avoid duplication of code. There was a reason for +# having two routines at one point but I can't remember what it was ... + +procedure sk_inprint (label, system, ctype, radecsys, equinox, epoch) + +char label[ARB] #I the input label +char system[ARB] #I the input system +int ctype #I the input coordinate type +int radecsys #I the input equatorial reference system +double equinox #I the input equinox +double epoch #I the input epoch of the observation + +pointer sp, radecstr +double sl_epj(), sl_epb() +int sk_wrdstr() + +begin + call smark (sp) + call salloc (radecstr, SZ_FNAME, TY_CHAR) + + switch (ctype) { + + case CTYPE_EQUATORIAL: + if (sk_wrdstr (radecsys, Memc[radecstr], SZ_FNAME, + EQTYPE_LIST) <= 0) + call strcpy ("FK5", Memc[radecstr], SZ_FNAME) + call strupr (Memc[radecstr]) + call printf ("%s: %s Coordinates: equatorial %s\n") + call pargstr (label) + call pargstr (system) + call pargstr (Memc[radecstr]) + switch (radecsys) { + case EQTYPE_GAPPT: + call printf (" MJD: %0.5f Epoch: J%0.8f B%0.8f\n") + call pargd (epoch) + if (IS_INDEFD(epoch)) { + call pargd (INDEFD) + call pargd (INDEFD) + } else { + call pargd (sl_epj (epoch)) + call pargd (sl_epb (epoch)) + } + case EQTYPE_FK5, EQTYPE_ICRS: + call printf (" Equinox: J%0.3f Epoch: J%0.8f MJD: %0.5f\n") + call pargd (equinox) + call pargd (sl_epj(epoch)) + call pargd (epoch) + default: + call printf (" Equinox: B%0.3f Epoch: B%0.8f MJD: %0.5f\n") + call pargd (equinox) + call pargd (sl_epb(epoch)) + call pargd (epoch) + } + + case CTYPE_ECLIPTIC: + call printf ("%s: %s Coordinates: ecliptic\n") + call pargstr (label) + call pargstr (system) + call printf (" MJD: %0.5f Epoch: J%0.8f B%0.8f\n") + call pargd (epoch) + if (IS_INDEFD(epoch)) { + call pargd (INDEFD) + call pargd (INDEFD) + } else { + call pargd (sl_epj(epoch)) + call pargd (sl_epb(epoch)) + } + + case CTYPE_GALACTIC: + call printf ("%s: %s Coordinates: galactic\n") + call pargstr (label) + call pargstr (system) + call printf (" MJD: %0.5f Epoch: J%0.8f B%0.8f\n") + call pargd (epoch) + call pargd (sl_epj (epoch)) + call pargd (sl_epb (epoch)) + + case CTYPE_SUPERGALACTIC: + call printf ("%s: %s Coordinates: supergalactic\n") + call pargstr (label) + call pargstr (system) + call printf (" MJD: %0.5f Epoch: J%0.8f B%0.8f\n") + call pargd (epoch) + call pargd (sl_epj (epoch)) + call pargd (sl_epb (epoch)) + + } + + call sfree (sp) +end + + +# SK_INWRITE -- Write a summary of the input coordinate system. + +procedure sk_inwrite (fd, label, system, ctype, radecsys, equinox, epoch) + +int fd #I the output file descriptor +char label[ARB] #I the input label +char system[ARB] #I the input system +int ctype #I the input coordinate type +int radecsys #I the input equatorial reference system +double equinox #I the input equinox +double epoch #I the input epoch of the observation + +pointer sp, radecstr +double sl_epj(), sl_epb() +int sk_wrdstr() + +begin + call smark (sp) + call salloc (radecstr, SZ_FNAME, TY_CHAR) + + switch (ctype) { + + case CTYPE_EQUATORIAL: + if (sk_wrdstr (radecsys, Memc[radecstr], SZ_FNAME, + EQTYPE_LIST) <= 0) + call strcpy ("FK5", Memc[radecstr], SZ_FNAME) + call strupr (Memc[radecstr]) + call fprintf (fd, "# %s: %s Coordinates: equatorial %s\n") + call pargstr (label) + call pargstr (system) + call pargstr (Memc[radecstr]) + switch (radecsys) { + case EQTYPE_GAPPT: + call fprintf (fd, "# MJD: %0.5f Epoch: J%0.8f B%0.8f\n") + call pargd (epoch) + if (IS_INDEFD(epoch)) { + call pargd (INDEFD) + call pargd (INDEFD) + } else { + call pargd (sl_epj(epoch)) + call pargd (sl_epb(epoch)) + } + case EQTYPE_FK5, EQTYPE_ICRS: + call fprintf (fd, + "# Equinox: J%0.3f Epoch: J%0.8f MJD: %0.5f\n") + call pargd (equinox) + call pargd (sl_epj(epoch)) + call pargd (epoch) + default: + call fprintf (fd, + "# Equinox: B%0.3f Epoch: B%0.8f MJD: %0.5f\n") + call pargd (equinox) + call pargd (sl_epb(epoch)) + call pargd (epoch) + } + + case CTYPE_ECLIPTIC: + call fprintf (fd, "# %s: %s Coordinates: ecliptic\n") + call pargstr (label) + call pargstr (system) + call fprintf (fd, "# MJD: %0.5f Epoch: J%0.8f B%0.8f\n") + call pargd (epoch) + if (IS_INDEFD(epoch)) { + call pargd (INDEFD) + call pargd (INDEFD) + } else { + call pargd (sl_epj(epoch)) + call pargd (sl_epb(epoch)) + } + + case CTYPE_GALACTIC: + call fprintf (fd, "# %s: %s Coordinates: galactic\n") + call pargstr (label) + call pargstr (system) + call fprintf (fd, "# MJD: %0.5f Epoch: J%0.8f B%0.8f\n") + call pargd (epoch) + call pargd (sl_epj(epoch)) + call pargd (sl_epb(epoch)) + + case CTYPE_SUPERGALACTIC: + call fprintf (fd, "# %s: %s Coordinates: supergalactic\n") + call pargstr (label) + call pargstr (system) + call fprintf (fd, "# MJD: %0.5f Epoch: J%0.8f B%0.8f\n") + call pargd (epoch) + call pargd (sl_epj(epoch)) + call pargd (sl_epb(epoch)) + + } + + call sfree (sp) +end + + +# SK_IMPRINT -- Print a summary of the input image coordinate system. +# This should probably be a call to sk_imwrite with the file descriptor +# set to STDOUT to avoid duplication of code. There was a reason for +# having two routines at one point but I can't remember what it was ... + +procedure sk_imprint (label, imagesys, ctype, lngax, latax, wtype, ptype, + radecsys, equinox, epoch) + +char label[ARB] #I input label +char imagesys[ARB] #I the input image name and system +int ctype #I the image coordinate type +int lngax #I the image ra/glon/elon axis +int latax #I the image dec/glat/elat axis +int wtype #I the image projection type +int ptype #I the image image wcs type +int radecsys #I the image equatorial reference system +double equinox #I the image equinox +double epoch #I the image epoch of the observation + +pointer sp, imname, projstr, wcsstr, radecstr +double sl_epj(), sl_epb() +int sk_wrdstr() + +begin + call smark (sp) + call salloc (imname, SZ_FNAME, TY_CHAR) + call salloc (projstr, SZ_FNAME, TY_CHAR) + call salloc (wcsstr, SZ_FNAME, TY_CHAR) + call salloc (radecstr, SZ_FNAME, TY_CHAR) + + call sscan (imagesys) + call gargwrd (Memc[imname], SZ_FNAME) + if (sk_wrdstr (wtype, Memc[projstr], SZ_FNAME, WTYPE_LIST) <= 0) + call strcpy ("linear", Memc[projstr], SZ_FNAME) + call strupr (Memc[projstr]) + if (sk_wrdstr (ptype, Memc[wcsstr], SZ_FNAME, PIXTYPE_LIST) <= 0) + call strcpy ("world", Memc[wcsstr], SZ_FNAME) + call strlwr (Memc[wcsstr]) + + switch (ctype) { + + case CTYPE_EQUATORIAL: + if (sk_wrdstr (radecsys, Memc[radecstr], SZ_FNAME, + EQTYPE_LIST) <= 0) + call strcpy ("FK5", Memc[radecstr], SZ_FNAME) + call strupr (Memc[radecstr]) + call printf ( + "%s: %s %s Projection: %s Ra/Dec axes: %d/%d\n") + call pargstr (label) + call pargstr (Memc[imname]) + call pargstr (Memc[wcsstr]) + call pargstr (Memc[projstr]) + call pargi (lngax) + call pargi (latax) + switch (radecsys) { + case EQTYPE_GAPPT: + call printf (" Coordinates: equatorial %s\n") + call pargstr (Memc[radecstr]) + call printf (" MJD: %0.5f Epoch: J%0.8f B%0.8f\n") + call pargd (epoch) + if (IS_INDEFD(epoch)) { + call pargd (INDEFD) + call pargd (INDEFD) + } else { + call pargd (sl_epj(epoch)) + call pargd (sl_epb(epoch)) + } + case EQTYPE_FK5, EQTYPE_ICRS: + call printf (" Coordinates: equatorial %s Equinox: J%0.3f\n") + call pargstr (Memc[radecstr]) + call pargd (equinox) + call printf (" Epoch: J%0.8f MJD: %0.5f\n") + call pargd (sl_epj (epoch)) + call pargd (epoch) + default: + call printf (" Coordinates: equatorial %s Equinox: B%0.3f\n") + call pargstr (Memc[radecstr]) + call pargd (equinox) + call printf (" Epoch: B%0.8f MJD: %0.5f\n") + call pargd (sl_epb (epoch)) + call pargd (epoch) + } + + case CTYPE_ECLIPTIC: + call printf ( + "%s: %s %s Projection: %s Elong/Elat axes: %d/%d\n") + call pargstr (label) + call pargstr (Memc[imname]) + call pargstr (Memc[wcsstr]) + call pargstr (Memc[projstr]) + call pargi (lngax) + call pargi (latax) + call printf (" Coordinates: ecliptic\n") + call printf (" MJD: %0.5f Epoch: J%0.8f B%0.8f\n") + call pargd (epoch) + if (IS_INDEFD(epoch)) { + call pargd (INDEFD) + call pargd (INDEFD) + } else { + call pargd (sl_epj(epoch)) + call pargd (sl_epb(epoch)) + } + + case CTYPE_GALACTIC: + call printf ( + "%s: %s %s Projection: %s Glong/Glat axes: %d/%d\n") + call pargstr (label) + call pargstr (Memc[imname]) + call pargstr (Memc[wcsstr]) + call pargstr (Memc[projstr]) + call pargi (lngax) + call pargi (latax) + call printf (" Coordinates: galactic\n") + call printf (" MJD: %0.5f Epoch: J%0.8f B%0.8f\n") + call pargd (epoch) + call pargd (sl_epj (epoch)) + call pargd (sl_epb (epoch)) + + case CTYPE_SUPERGALACTIC: + call printf ( + "%s: %s %s Projection: %s Slong/Slat axes: %d/%d\n") + call pargstr (label) + call pargstr (Memc[imname]) + call pargstr (Memc[wcsstr]) + call pargstr (Memc[projstr]) + call pargi (lngax) + call pargi (latax) + call printf (" Coordinates: supergalactic\n") + call printf (" MJD: %0.5f Epoch: J%0.8f B%0.8f\n") + call pargd (epoch) + call pargd (sl_epj (epoch)) + call pargd (sl_epb (epoch)) + } + + call sfree (sp) +end + + +# SK_IMWRITE -- Write a summary of the image coordinate system to the +# output file. + +procedure sk_imwrite (fd, label, imagesys, ctype, lngax, latax, wtype, ptype, + radecsys, equinox, epoch) + +int fd #I the output file descriptor +char label[ARB] #I input label +char imagesys[ARB] #I the input image name and wcs +int ctype #I the image coordinate type +int lngax #I the image ra/glon/elon axis +int latax #I the image dec/glat/elat axis +int wtype #I the image projection type +int ptype #I the image image wcs type +int radecsys #I the image equatorial reference system +double equinox #I the image equinox +double epoch #I the image epoch of the observation + +pointer sp, imname, projstr, wcsstr, radecstr +double sl_epj(), sl_epb() +int sk_wrdstr() + +begin + call smark (sp) + call salloc (imname, SZ_FNAME, TY_CHAR) + call salloc (projstr, SZ_FNAME, TY_CHAR) + call salloc (wcsstr, SZ_FNAME, TY_CHAR) + call salloc (radecstr, SZ_FNAME, TY_CHAR) + + call sscan (imagesys) + call gargwrd (Memc[imname], SZ_FNAME) + if (sk_wrdstr (wtype, Memc[projstr], SZ_FNAME, WTYPE_LIST) <= 0) + call strcpy ("linear", Memc[projstr], SZ_FNAME) + call strupr (Memc[projstr]) + if (sk_wrdstr (ptype, Memc[wcsstr], SZ_FNAME, PIXTYPE_LIST) <= 0) + call strcpy ("world", Memc[wcsstr], SZ_FNAME) + call strlwr (Memc[wcsstr]) + + switch (ctype) { + + case CTYPE_EQUATORIAL: + if (sk_wrdstr (radecsys, Memc[radecstr], SZ_FNAME, + EQTYPE_LIST) <= 0) + call strcpy ("FK5", Memc[radecstr], SZ_FNAME) + call strupr (Memc[radecstr]) + call fprintf (fd, + "# %s: %s %s Projection: %s Ra/Dec axes: %d/%d\n") + call pargstr (label) + call pargstr (Memc[imname]) + call pargstr (Memc[wcsstr]) + call pargstr (Memc[projstr]) + call pargi (lngax) + call pargi (latax) + switch (radecsys) { + case EQTYPE_GAPPT: + call fprintf (fd, "# Coordinates: equatorial %s\n") + call pargstr (Memc[radecstr]) + call fprintf (fd, "# MJD: %0.5f Epoch: J%0.8f B%0.8f\n") + call pargd (epoch) + if (IS_INDEFD(epoch)) { + call pargd (INDEFD) + call pargd (INDEFD) + } else { + call pargd (sl_epj(epoch)) + call pargd (sl_epb(epoch)) + } + case EQTYPE_FK5, EQTYPE_ICRS: + call fprintf (fd, + "# Coordinates: equatorial %s Equinox: J%0.3f\n") + call pargstr (Memc[radecstr]) + call pargd (equinox) + call fprintf (fd, "# Epoch: J%0.8f MJD: %0.5f\n") + call pargd (sl_epj(epoch)) + call pargd (epoch) + default: + call fprintf (fd, + "# Coordinates: equatorial %s Equinox: B%0.3f\n") + call pargstr (Memc[radecstr]) + call pargd (equinox) + call fprintf (fd, "# Epoch: B%0.8f MJD: %0.5f\n") + call pargd (sl_epb (epoch)) + call pargd (epoch) + } + + case CTYPE_ECLIPTIC: + call fprintf (fd, + "# %s: %s %s Projection: %s Elong/Elat axes: %d/%d\n") + call pargstr (label) + call pargstr (Memc[imname]) + call pargstr (Memc[wcsstr]) + call pargstr (Memc[projstr]) + call pargi (lngax) + call pargi (latax) + call fprintf (fd, "# Coordinates: ecliptic\n") + call fprintf (fd, "# MJD: %0.5f Epoch: J%0.8f B%0.8f\n") + call pargd (epoch) + if (IS_INDEFD(epoch)) { + call pargd (INDEFD) + call pargd (INDEFD) + } else { + call pargd (sl_epj(epoch)) + call pargd (sl_epb(epoch)) + } + + case CTYPE_GALACTIC: + call fprintf (fd, + "# %s: %s %s Projection: %s Glong/Glat axes: %d/%d\n") + call pargstr (label) + call pargstr (Memc[imname]) + call pargstr (Memc[wcsstr]) + call pargstr (Memc[projstr]) + call pargi (lngax) + call pargi (latax) + call fprintf (fd, "# Coordinates: galactic\n") + call fprintf (fd, "# MJD: %0.5f Epoch: J%0.8f B%0.8f\n") + call pargd (epoch) + call pargd (sl_epj(epoch)) + call pargd (sl_epb(epoch)) + + case CTYPE_SUPERGALACTIC: + call fprintf (fd, + "# %s: %s %s Projection: %s Slong/Slat axes: %d/%d\n") + call pargstr (label) + call pargstr (Memc[imname]) + call pargstr (Memc[wcsstr]) + call pargstr (Memc[projstr]) + call pargi (lngax) + call pargi (latax) + call fprintf (fd, "# Coordinates: supergalactic\n") + call fprintf (fd, "# MJD: %0.5f Epoch: J%0.8f B%0.8f\n") + call pargd (epoch) + call pargd (sl_epj(epoch)) + call pargd (sl_epb(epoch)) + } + + call sfree (sp) +end diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skywcs.h b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skywcs.h new file mode 100644 index 00000000..c0c6a3b7 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skywcs.h @@ -0,0 +1,132 @@ +# Public definitions file for the SKYWCS library. + +# Define the SKYWCS library parameters. + +define S_VXOFF 1 +define S_VYOFF 2 +define S_VXSTEP 3 +define S_VYSTEP 4 +define S_EQUINOX 5 +define S_EPOCH 6 +define S_CTYPE 7 +define S_RADECSYS 8 +define S_WTYPE 9 +define S_PLNGAX 10 +define S_PLATAX 11 +define S_XLAX 12 +define S_YLAX 13 +define S_PIXTYPE 14 +define S_NLNGAX 15 +define S_NLATAX 16 +define S_NLNGUNITS 17 +define S_NLATUNITS 18 +define S_COOSYSTEM 19 +define S_STATUS 20 + +# Define the list of supported fundamental coordinate systems. + +define FTYPE_LIST "|fk4|noefk4|fk5|icrs|apparent|ecliptic|galactic|\ +supergalactic|" + +define FTYPE_FK4 1 +define FTYPE_FK4NOE 2 +define FTYPE_FK5 3 +define FTYPE_ICRS 4 +define FTYPE_GAPPT 5 +define FTYPE_ECLIPTIC 6 +define FTYPE_GALACTIC 7 +define FTYPE_SUPERGALACTIC 8 + +# Define the list of supported coordinate systems. + +define CTYPE_LIST "|equatorial|ecliptic|galactic|supergalactic|" + +define CTYPE_EQUATORIAL 1 +define CTYPE_ECLIPTIC 2 +define CTYPE_GALACTIC 3 +define CTYPE_SUPERGALACTIC 4 + +# Define the supported equatoral reference systems. + +define EQTYPE_LIST "|fk4|fk4-no-e|fk5|icrs|gappt|" + +define EQTYPE_FK4 1 +define EQTYPE_FK4NOE 2 +define EQTYPE_FK5 3 +define EQTYPE_ICRS 4 +define EQTYPE_GAPPT 5 + +# Define the input coordinate file longitude latitude units. + +define SKY_LNG_UNITLIST "|degrees|radians|hours|" +define SKY_LAT_UNITLIST "|degrees|radians|" + +define SKY_DEGREES 1 +define SKY_RADIANS 2 +define SKY_HOURS 3 + +# Define the list of supported image sky projection types. + +define WTYPE_LIST "|lin|azp|tan|sin|stg|arc|zpn|zea|air|cyp|car|\ +mer|cea|cop|cod|coe|coo|bon|pco|gls|par|ait|mol|csc|qsc|tsc|tnx|zpx|" + +define PTYPE_LIST "|z|z|z|z|z|z|z|z|z|c|c|c|c|n|n|n|n|c|c|c|c|c|c|c|c|c|\ +x|x|" + +define WTYPE_LIN 1 +define WTYPE_AZP 2 +define WTYPE_TAN 3 +define WTYPE_SIN 4 +define WTYPE_STG 5 +define WTYPE_ARC 6 +define WTYPE_ZPN 7 +define WTYPE_ZEA 8 +define WTYPE_AIR 9 +define WTYPE_CYP 10 +define WTYPE_CAR 11 +define WTYPE_MER 12 +define WTYPE_CEA 13 +define WTYPE_COP 14 +define WTYPE_COD 15 +define WTYPE_COE 16 +define WTYPE_COO 17 +define WTYPE_BON 18 +define WTYPE_PCO 19 +define WTYPE_GLS 20 +define WTYPE_PAR 21 +define WTYPE_AIT 22 +define WTYPE_MOL 23 +define WTYPE_CSC 24 +define WTYPE_QSC 25 +define WTYPE_TSC 26 +define WTYPE_TNX 27 +define WTYPE_ZPX 28 + +define PTYPE_NAMES "|z|c|n|x|" + +define PTYPE_ZEN 1 +define PTYPE_CYL 2 +define PTYPE_CON 3 +define PTYPE_EXP 4 + +# Define the supported image axis types. + +define AXTYPE_LIST "|ra|dec|glon|glat|elon|elat|slon|slat|" + +define AXTYPE_RA 1 +define AXTYPE_DEC 2 +define AXTYPE_GLON 3 +define AXTYPE_GLAT 4 +define AXTYPE_ELON 5 +define AXTYPE_ELAT 6 +define AXTYPE_SLON 7 +define AXTYPE_SLAT 8 + +# Define the supported image pixel coordinate systems. + +define PIXTYPE_LIST "|logical|tv|physical|world|" + +define PIXTYPE_LOGICAL 1 +define PIXTYPE_TV 2 +define PIXTYPE_PHYSICAL 3 +define PIXTYPE_WORLD 4 diff --git a/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skywcsdef.h b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skywcsdef.h new file mode 100644 index 00000000..433247bd --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/skywcs/skywcsdef.h @@ -0,0 +1,24 @@ +# The SKYWCS library structure. + +define LEN_SKYCOOSTRUCT (30 + SZ_FNAME + 1) + +define SKY_VXOFF Memd[P2D($1)] # logical ra/longitude offset +define SKY_VYOFF Memd[P2D($1+2)] # logical dec/tatitude offset +define SKY_VXSTEP Memd[P2D($1+4)] # logical ra/longitude stepsize +define SKY_VYSTEP Memd[P2D($1+6)] # logical dec/latitude stepsize +define SKY_EQUINOX Memd[P2D($1+8)] # equinox of ra/dec system (B or J) +define SKY_EPOCH Memd[P2D($1+10)] # epoch of observation (MJD) +define SKY_CTYPE Memi[$1+12] # celestial coordinate system code +define SKY_RADECSYS Memi[$1+13] # ra/dec system code +define SKY_WTYPE Memi[$1+14] # sky projection function code +define SKY_PLNGAX Memi[$1+15] # physical ra/longitude axis +define SKY_PLATAX Memi[$1+16] # physical dec/latitude axis +define SKY_XLAX Memi[$1+17] # logical ra/longitude axis +define SKY_YLAX Memi[$1+18] # logical dec/latitude axis +define SKY_PIXTYPE Memi[$1+19] # iraf wcs system code +define SKY_NLNGAX Memi[$1+20] # length of ra/longitude axis +define SKY_NLATAX Memi[$1+21] # length of dec/latitude axis +define SKY_NLNGUNITS Memi[$1+22] # the native ra/longitude units +define SKY_NLATUNITS Memi[$1+23] # the native dec/latitude units +define SKY_STATUS Memi[$1+24] # the status (OK or ERR) +define SKY_COOSYSTEM Memc[P2C($1+25)] # the coordinate system name diff --git a/vendor/x11iraf/ximtool/clients.old/lib/wcsgfterm.f b/vendor/x11iraf/ximtool/clients.old/lib/wcsgfterm.f new file mode 100644 index 00000000..a8f7b191 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/wcsgfterm.f @@ -0,0 +1,89 @@ + subroutine wcsgfm (mw, crpix, crval, cd, ndim) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer mw + integer ndim + double precision crpix(ndim) + double precision crval(ndim) + double precision cd(ndim,ndim) + integer sp + integer r + integer wcd + integer ltv + integer ltm + integer iltm + integer alert + integer errmsg + integer i + integer errcoe + integer errget + logical xerpop + logical xerflg + common /xercom/ xerflg + integer*2 st0001(8) + integer*2 st0002(26) + integer*2 st0003(1) + integer*2 st0004(1) + save + integer iyy + data st0001 / 37,115, 10, 34, 37,115, 34, 0/ + data (st0002(iyy),iyy= 1, 8) / 69,114,114,111,114, 32,100,101/ + data (st0002(iyy),iyy= 9,16) / 99,111,100,105,110,103, 32,105/ + data (st0002(iyy),iyy=17,24) /109, 97,103,101, 32, 87, 67, 83/ + data (st0002(iyy),iyy=25,26) / 58, 0/ + data st0003 / 0/ + data st0004 / 0/ + call smark (sp) + call salloc (r, ndim, 7) + call salloc (wcd, ndim * ndim, 7) + call salloc (ltv, ndim, 7) + call salloc (ltm, ndim * ndim, 7) + call salloc (iltm, ndim * ndim, 7) + call xerpsh + call mwgwtd (mw, memd(r), crval, memd(wcd), ndim) + if (xerflg) goto 112 + call mwgltd (mw, memd(ltm), memd(ltv), ndim) + if (xerflg) goto 112 + call mwvmud (memd(ltm), memd(r), crpix, ndim) + call aaddd (crpix, memd(ltv), crpix, ndim) + call mwinvd (memd(ltm), memd(iltm), ndim) + call mwmmud (memd(wcd), memd(iltm), cd, ndim) +112 if (.not.xerpop()) goto 110 + call salloc (alert, 1023 , 2) + call salloc (errmsg, 1023 , 2) + call aclrd (cd, ndim*ndim) + i=1 +120 if (.not.(i .le. ndim)) goto 122 + crpix(i) = 1.0d0 + crval(i) = 1.0d0 + cd(i,i) = 1.0d0 +121 i=i+1 + goto 120 +122 continue + errcoe = errget (memc(errmsg), 1023 ) + call sprinf (memc(alert), 255 , st0001) + call pargsr (st0002) + call pargsr (memc(errmsg)) + call ximalt (memc(alert), st0003, st0004) +110 continue + call sfree (sp) +100 return + end +c sprinf sprintf +c mwinvd mwinvertd +c mwvmud mwvmuld +c errcoe errcode +c mwgwtd mw_gwtermd +c ximalt xim_alert +c mwmmud mwmmuld +c pargsr pargstr +c wcsgfm wcs_gfterm +c mwgltd mw_gltermd diff --git a/vendor/x11iraf/ximtool/clients.old/lib/wcsgfterm.x b/vendor/x11iraf/ximtool/clients.old/lib/wcsgfterm.x new file mode 100644 index 00000000..8b97a55b --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/wcsgfterm.x @@ -0,0 +1,61 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + + +# WCS_GFTERM -- Compute the output FITS CRPIX, CRVAL, and CD arrays from the +# MWCS LTERM and WTERM. Note that the CD matrix terms are still transposed +# from the usual Fortran order. + +procedure wcs_gfterm (mw, crpix, crval, cd, ndim) + +pointer mw #i the input mwcs pointer +double crpix[ndim] #o the output FITS CRPIX array +double crval[ndim] #o the output FITS CRVAL array +double cd[ndim,ndim] #o the output FITS CD matrix +int ndim #i the dimensionality of the wcs + +pointer sp, r, wcd, ltv, ltm, iltm +pointer alert, errmsg +int i, errcode + +int errget() + +errchk mw_gwtermd, mw_gltermd + +begin + call smark (sp) + call salloc (r, ndim, TY_DOUBLE) + call salloc (wcd, ndim * ndim, TY_DOUBLE) + call salloc (ltv, ndim, TY_DOUBLE) + call salloc (ltm, ndim * ndim, TY_DOUBLE) + call salloc (iltm, ndim * ndim, TY_DOUBLE) + + iferr { + call mw_gwtermd (mw, Memd[r], crval, Memd[wcd], ndim) + call mw_gltermd (mw, Memd[ltm], Memd[ltv], ndim) + call mwvmuld (Memd[ltm], Memd[r], crpix, ndim) + call aaddd (crpix, Memd[ltv], crpix, ndim) + call mwinvertd (Memd[ltm], Memd[iltm], ndim) + call mwmmuld (Memd[wcd], Memd[iltm], cd, ndim) + + } then { + call salloc (alert, SZ_LINE, TY_CHAR) + call salloc (errmsg, SZ_LINE, TY_CHAR) + + # Set up a default value. + call aclrd (cd, ndim*ndim) + for (i=1; i <= ndim; i=i+1) { + crpix[i] = 1.0d0 + crval[i] = 1.0d0 + cd[i,i] = 1.0d0 + } + + # Send alert to the GUI. + errcode = errget (Memc[errmsg], SZ_LINE) + call sprintf (Memc[alert], SZ_FNAME, "%s\n\"%s\"") + call pargstr ("Error decoding image WCS:") + call pargstr (Memc[errmsg]) + call xim_alert (Memc[alert], "", "") + } + + call sfree (sp) +end diff --git a/vendor/x11iraf/ximtool/clients.old/lib/ximtool.f b/vendor/x11iraf/ximtool/clients.old/lib/ximtool.f new file mode 100644 index 00000000..80dabf3f --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/ximtool.f @@ -0,0 +1,510 @@ + integer function ximcot (device, name, type) + integer*2 device(*) + integer*2 name(*) + integer*2 type(*) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer sp + integer cmsg + integer dev + integer buf + integer msglen + integer*2 connet(255 +1) + integer ndopen + integer reopen + integer xstrln + integer ximred + logical streq + external ximonr + integer fdin + integer fdout + integer mode + integer nbuf + integer nr + integer nw + integer*2 buffer(2047+1) + integer ximepa + integer ximstt + integer oldont + integer ximfd + integer ximjmp(64 ) + integer ximert + logical xerpop + logical xerflg + common /xercom/ xerflg + common /ximfd/ fdin, fdout, mode, nbuf, buffer, nr, nw + common /ximcom/ ximfd, ximjmp, ximepa, ximstt, oldont + common /ximecm/ ximert + integer*2 st0001(6) + integer*2 st0002(5) + integer*2 st0003(12) + integer*2 st0004(8) + integer*2 st0005(12) + integer*2 st0006(21) + integer*2 st0007(10) + integer*2 st0008(8) + save + integer iyy + data st0001 / 37,115, 58, 37,115, 0/ + data st0002 /116,101,120,116, 0/ + data (st0003(iyy),iyy= 1, 8) / 99,111,110,110,101, 99,116, 32/ + data (st0003(iyy),iyy= 9,12) / 37,115, 0, 0/ + data st0004 /120,105,109,116,111,111,108, 0/ + data (st0005(iyy),iyy= 1, 8) /117,110,105,120, 58, 37,115, 58/ + data (st0005(iyy),iyy= 9,12) / 37,115, 0, 0/ + data (st0006(iyy),iyy= 1, 8) / 82,101, 99,111,110,110,101, 99/ + data (st0006(iyy),iyy= 9,16) /116,101,100, 32,111,110, 32, 39/ + data (st0006(iyy),iyy=17,21) / 37,115, 39, 10, 0/ + data (st0007(iyy),iyy= 1, 8) /114,101, 97,100,121, 32, 37,115/ + data (st0007(iyy),iyy= 9,10) / 0, 0/ + data st0008 /120,105,109,116,111,111,108, 0/ + data ximert /0/ + call smark (sp) + call salloc (buf, 1023 , 2) + call salloc (cmsg, 1023 , 2) + call salloc (dev, 255 , 2) + call aclrc (memc(buf), 1023 ) + call aclrc (memc(cmsg), 1023 ) + call aclrc (memc(dev), 255 ) + call aclrc (buffer, 2047) + fdin = 0 + fdout = 0 + nbuf = 0 + nr = 0 + nw = 0 + call sprinf (memc(dev), 255 , st0001) + call pargsr (device) + call pargsr (type) + if (.not.(streq (type, st0002))) goto 110 + mode = 1 + goto 111 +110 continue + mode = 2 +111 continue + call xerpsh + fdin = ndopen (memc(dev), 2) + if (.not.xerpop()) goto 120 + call sfree (sp) + ximcot = (-1) + goto 100 +120 continue + fdout = reopen (fdin, 2) + call sprinf (memc(cmsg), 1023 , st0003) + call pargsr (name) + msglen = xstrln(memc(cmsg)) + call ximmee (st0004, memc(cmsg)) + if (.not.(ximred (memc(buf), msglen) .eq. -2)) goto 130 + call sfree (sp) + ximcot = (-1) + goto 100 +130 continue + call xfcloe(fdout) + call xfcloe(fdin) + call sprinf (connet, 1023 , st0005) + call pargsr (memc(buf+8)) + call pargsr (type) + call xerpsh + fdin = ndopen (connet, 2) + if (.not.xerpop()) goto 140 + call sfree (sp) + ximcot = (-1) + goto 100 +140 continue + fdout = reopen (fdin, 2) + if (.not.(.true.)) goto 150 + call eprinf (st0006) + call pargsr (connet) +150 continue + call sprinf (memc(cmsg), 1023 , st0007) + call pargsr (name) + msglen = xstrln(memc(cmsg)) + call ximmee (st0008, memc(cmsg)) + call onerrr (ximonr) + call sfree (sp) + ximcot = (0) + goto 100 +100 return + end + subroutine ximdit (sendqt) + integer sendqt + integer fdin + integer fdout + integer mode + integer nbuf + integer nr + integer nw + integer*2 buffer(2047+1) + common /ximfd/ fdin, fdout, mode, nbuf, buffer, nr, nw + integer*2 st0001(8) + integer*2 st0002(5) + save + data st0001 /120,105,109,116,111,111,108, 0/ + data st0002 /113,117,105,116, 0/ + if (.not.(sendqt .eq. 1)) goto 110 + call ximmee (st0001, st0002) +110 continue + call xffluh(fdout) + call xfcloe(fdin) + call xfcloe(fdout) + fdin = 0 + fdout = 0 +100 return + end + subroutine ximmee (object, messae) + integer*2 object(*) + integer*2 messae(*) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer sp + integer msgbuf + integer msglen + integer olen + integer mlen + integer ip + integer xstrln + logical streq + integer*2 st0001(8) + integer*2 st0002(6) + integer*2 st0003(4) + integer*2 st0004(4) + save + data st0001 /120,105,109,116,111,111,108, 0/ + data st0002 /115,101,110,100, 32, 0/ + data st0003 / 32,123, 32, 0/ + data st0004 / 32,125, 0, 0/ + olen = xstrln(object) + mlen = xstrln(messae) + msglen = olen + mlen + 20 + call smark (sp) + call salloc (msgbuf, msglen, 2) + call aclrc (memc(msgbuf), msglen) + if (.not.(streq (object, st0001))) goto 110 + call xstrcy(messae, memc(msgbuf), msglen) + goto 111 +110 continue + ip = 0 + call amovc (st0002, memc(msgbuf+ip), 5) + ip = ip + 5 + call amovc (object, memc(msgbuf+ip), olen) + ip = ip + olen + call amovc (st0003, memc(msgbuf+ip), 3) + ip = ip + 3 + call amovc (messae, memc(msgbuf+ip), mlen) + ip = ip + mlen + call amovc (st0004, memc(msgbuf+ip), 2) + ip = ip + 3 +111 continue + msglen = xstrln(memc(msgbuf)) + call ximwre (memc(msgbuf), msglen) + call sfree (sp) +100 return + end + subroutine ximalt (text, ok, cancel) + integer*2 text(*) + integer*2 ok(*) + integer*2 cancel(*) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer sp + integer msg + integer*2 st0001(15) + integer*2 st0002(6) + save + integer iyy + data (st0001(iyy),iyy= 1, 8) /123, 37,115,125, 32,123, 37,115/ + data (st0001(iyy),iyy= 9,15) /125, 32,123, 37,115,125, 0/ + data st0002 / 97,108,101,114,116, 0/ + call smark (sp) + call salloc (msg, 1023 , 2) + call sprinf (memc(msg), 1023 , st0001) + call pargsr (text) + call pargsr (ok) + call pargsr (cancel) + call ximmee (st0002, memc(msg)) + call sfree (sp) +100 return + end + subroutine ximwre (messae, len) + integer len + integer*2 messae(*) + integer nleft + integer n + integer ip + integer*2 msgbuf(2047+1) + integer xstrln + integer fdin + integer fdout + integer mode + integer nbuf + integer nr + integer nw + integer*2 buffer(2047+1) + common /ximfd/ fdin, fdout, mode, nbuf, buffer, nr, nw + logical xerflg + common /xercom/ xerflg + integer*2 st0001(42) + save + integer iyy + data (st0001(iyy),iyy= 1, 8) /120,105,109, 95,119,114,105,116/ + data (st0001(iyy),iyy= 9,16) /101, 58, 32, 39, 37, 46, 52, 53/ + data (st0001(iyy),iyy=17,24) /115, 39, 32,108,101,110, 61, 37/ + data (st0001(iyy),iyy=25,32) /100, 32,109,111,100,101, 61, 37/ + data (st0001(iyy),iyy=33,40) /100, 32,116,111,116, 61, 37,100/ + data (st0001(iyy),iyy=41,42) / 10, 0/ + len = xstrln(messae) + 1 + messae(len) = 0 + if (.not.(mod(len,2) .eq. 1)) goto 110 + len = len + 1 + messae(len) = 0 +110 continue + ip = 1 + nleft = len +120 if (.not.(nleft .gt. 0)) goto 121 + n = min (nleft, 2047) + call amovc (messae(ip), msgbuf, n) + if (.not.(mode .eq. 2)) goto 130 + call achtcb (msgbuf, msgbuf, n) + call xfwrie(fdout, msgbuf, n / 2 ) + if (xerflg) goto 100 + goto 131 +130 continue + call xfwrie(fdout, msgbuf, n) + if (xerflg) goto 100 +131 continue + ip = ip + n + nleft = nleft - n + goto 120 +121 continue + nw = nw + len + call xffluh(fdout) + if (xerflg) goto 100 + if (.not.(.true.)) goto 140 + call eprinf (st0001) + call pargsr (messae) + call pargi (len) + call pargi (mode) + call pargi (nw) +140 continue +100 return + end + integer function ximred (messae, len) + integer len + integer*2 messae(*) + integer i + integer n + integer nleft + integer xfread + integer fdin + integer fdout + integer mode + integer nbuf + integer nr + integer nw + integer*2 buffer(2047+1) + integer ximepa + integer ximstt + integer oldont + integer ximfd + integer ximjmp(64 ) + logical xerpop + logical xerflg + common /xercom/ xerflg + common /ximfd/ fdin, fdout, mode, nbuf, buffer, nr, nw + common /ximcom/ ximfd, ximjmp, ximepa, ximstt, oldont + integer*2 st0001(42) + integer*2 st0002(40) + save + integer iyy + data (st0001(iyy),iyy= 1, 8) /120,105,109, 95,114,101, 97,100/ + data (st0001(iyy),iyy= 9,16) / 58, 32,116,111,116, 61, 37,100/ + data (st0001(iyy),iyy=17,24) / 32,108,101,110, 61, 37,100, 47/ + data (st0001(iyy),iyy=25,32) / 37,100, 32,109,115,103, 61, 39/ + data (st0001(iyy),iyy=33,40) / 37, 51, 48, 46, 51, 48,115, 39/ + data (st0001(iyy),iyy=41,42) / 10, 0/ + data (st0002(iyy),iyy= 1, 8) /120,105,109, 95,114,101, 97,100/ + data (st0002(iyy),iyy= 9,16) / 58, 32,110, 98,117,102, 61, 37/ + data (st0002(iyy),iyy=17,24) /100, 32,110,108,101,102,116, 61/ + data (st0002(iyy),iyy=25,32) / 37,100, 32, 98,117,102,102,101/ + data (st0002(iyy),iyy=33,40) /114, 61, 39, 37,115, 39, 10, 0/ + if (.not.(nbuf .eq. 0)) goto 110 + call aclrc (buffer, 2047) + nbuf = 0 + call xerpsh + n = xfread(fdin, messae, 2047) + if (xerflg) goto 122 + if (.not.(n .lt. 0)) goto 130 + ximred = (-2) + goto 100 +130 continue +122 if (.not.xerpop()) goto 120 + call xerret() + call zdojmp (ximjmp, 504 ) +120 continue + if (.not.(mode .eq. 2)) goto 140 + len = n * 2 + call achtbc (messae, messae, len) + goto 141 +140 continue + len = n +141 continue + call amovc (messae, buffer, len) + if (.not.(buffer(len) .eq. 0 .and. buffer(len-1) .eq. 0)) + * goto 150 + nbuf = len + goto 151 +150 continue + nbuf = len + 1 +151 continue + buffer(nbuf) = -2 +110 continue + i=1 +160 if (.not.(buffer(i) .ne. 0 .and. buffer(i) .ne. -2 .and. i .le. + * nbuf)) goto 162 + messae(i) = buffer(i) +161 i=i+1 + goto 160 +162 continue + messae(i) = 0 + len = i + nleft = nbuf - i + nr = nr + len + if (.not.(buffer(i) .eq. 0 .and. buffer(i+1) .eq. -2)) goto 170 + if (.not.(i .gt. 1 .and. nleft .gt. 1)) goto 180 + call amovc (buffer(i+1), buffer, nleft) +180 continue + nbuf = 0 + goto 171 +170 continue + if (.not.(nleft .gt. 0)) goto 190 + call amovc (buffer(i+1), buffer, nleft) +190 continue + nbuf = nleft +171 continue + if (.not.(.true.)) goto 200 + call eprinf (st0001) + call pargi(nr) + call pargi (len) + call pargsr(messae) + call eprinf (st0002) + call pargi (nbuf) + call pargi(nleft) + call pargsr(buffer) +200 continue + ximred = (nleft) + goto 100 +100 return + end + integer function ximinr () + external ximzxn + integer ximepa + integer ximstt + integer oldont + integer ximfd + integer ximjmp(64 ) + common /ximcom/ ximfd, ximjmp, ximepa, ximstt, oldont + save + call zlocpr (ximzxn, ximepa) + call xwhen (503 , ximepa, oldont) + call zsvjmp (ximjmp, ximstt) + if (.not.(ximstt .eq. 0)) goto 110 + ximinr = (0) + goto 100 +110 continue + ximinr = (-1) + goto 100 +111 continue +100 return + end + subroutine ximzxn (vex, nexthr) + integer vex + integer nexthr + integer ximepa + integer ximstt + integer oldont + integer ximfd + integer ximjmp(64 ) + common /ximcom/ ximfd, ximjmp, ximepa, ximstt, oldont + save + call ximdit (1) + call xerret() + call zdojmp (ximjmp, vex) +100 return + end + subroutine ximonr (status) + integer status + integer ximert + integer code + integer*2 buf(1023 +1) + integer*2 errmsg(1023 +1) + integer errget + integer ximepa + integer ximstt + integer oldont + integer ximfd + integer ximjmp(64 ) + common /ximecm/ ximert + common /ximcom/ ximfd, ximjmp, ximepa, ximstt, oldont + integer*2 st0001(25) + save + integer iyy + data (st0001(iyy),iyy= 1, 8) / 73, 83, 77, 32, 69,114,114,111/ + data (st0001(iyy),iyy= 9,16) /114, 44, 32, 99,111,100,101, 32/ + data (st0001(iyy),iyy=17,24) / 37,100, 58, 10, 96, 37,115, 39/ + data (st0001(iyy),iyy=25,25) / 0/ + if (.not.(status .ne. 0)) goto 110 + code = errget (errmsg, 1023 ) + call sprinf (buf, 1023 , st0001) + call pargi (status) + call pargsr (errmsg) + call ximalt (buf, 0, 0) + call ximdit (1) +110 continue +100 return + end +c ximonr xim_onerror +c sprinf sprintf +c onerrr onerror +c ximstt ximstat +c ximmee xim_message +c messae message +c ximcot xim_connect +c connet connect +c ximinr xim_intrhandler +c ximalt xim_alert +c oldont old_onint +c ximecm ximecom +c ximred xim_read +c ximjmp xim_jmp +c sendqt send_quit +c eprinf eprintf +c nexthr next_handler +c ximzxn xim_zxwhen +c xerret xer_reset +c ximdit xim_disconnect +c ximwre xim_write +c pargsr pargstr +c ximert xim_errstat diff --git a/vendor/x11iraf/ximtool/clients.old/lib/ximtool.x b/vendor/x11iraf/ximtool/clients.old/lib/ximtool.x new file mode 100644 index 00000000..dff5869c --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/ximtool.x @@ -0,0 +1,459 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include <config.h> +include <mach.h> +include <xwhen.h> + + +# XIMTOOL.X -- Interface routines for client programs to connect to +# XImtool on the message bus. +# +# status = xim_connect (device, name, mode) +# status = xim_file_connect (infile, outfile, name) +# xim_disconnect (send_quit) +# xim_message (object, message) +# xim_alert (text, ok_action, cancel_action) +# +# xim_write (message, len) +# nremain = xim_read (message, len) +# +# Client programs should install an exception handler to first disconnect +# from the device before shutting down. The procedure xim_zxwhen() is +# provided for this purpose. + + +define XIM_DBG TRUE + +define SZ_MESSAGE 2047 + +define XIM_TEXT 1 +define XIM_BINARY 2 + + +# XIM_CONNECT -- Negotiate a connection on the named device. Once +# established we can begin sending and reading messages from the server. + +int procedure xim_connect (device, name, type) + +char device[ARB] #I socket to connect on +char name[ARB] #I module name +char type[ARB] #I requested connection mode + +pointer sp, cmsg, dev, buf +int msglen +char connect[SZ_FNAME] + +int ndopen(), reopen(), strlen() +int xim_read() +bool streq() + +extern xim_onerror() + +# I/O common. +int fdin, fdout, mode, nbuf, nr, nw +char buffer[SZ_MESSAGE] +common /ximfd/ fdin, fdout, mode, nbuf, buffer, nr, nw + +# Interrupt handler variables common. +int ximepa, ximstat, old_onint, xim_fd, xim_jmp[LEN_JUMPBUF] +common /ximcom/ xim_fd, xim_jmp, ximepa, ximstat, old_onint + +# Exception handler variables common. +int xim_errstat +data xim_errstat /OK/ +common /ximecom/ xim_errstat + +begin + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + call salloc (cmsg, SZ_LINE, TY_CHAR) + call salloc (dev, SZ_FNAME, TY_CHAR) + + # Initialize. + call aclrc (Memc[buf], SZ_LINE) + call aclrc (Memc[cmsg], SZ_LINE) + call aclrc (Memc[dev], SZ_FNAME) + call aclrc (buffer, SZ_MESSAGE) + fdin = NULL + fdout = NULL + nbuf = 0 + nr = 0 + nw = 0 + + # Generate the device name. We assume the call was made with either + # a "unix:" or "inet:" prefix, so just append the type and set the + # mode. + + call sprintf (Memc[dev], SZ_FNAME, "%s:%s") + call pargstr (device) + call pargstr (type) + if (streq (type, "text")) + mode = XIM_TEXT + else + mode = XIM_BINARY + + # Open the initial connection + iferr (fdin = ndopen (Memc[dev], READ_WRITE)) { + call sfree (sp) + return (ERR) + } + fdout = reopen (fdin, READ_WRITE) + + # Send the connect request. + call sprintf (Memc[cmsg], SZ_LINE, "connect %s\0") + call pargstr (name) + msglen = strlen (Memc[cmsg]) + call xim_message ("ximtool", Memc[cmsg]) + + # Read the acknowledgement. + if (xim_read (Memc[buf], msglen) == EOF) { + call sfree (sp) + return (ERR) + } + + # Close the original socket. + call close (fdout) + call close (fdin) + + # Get the new device name. + call sprintf (connect, SZ_LINE, "unix:%s:%s\0") + call pargstr (Memc[buf+8]) + call pargstr (type) + + # Open the new channel. + iferr (fdin = ndopen (connect, READ_WRITE)) { + call sfree (sp) + return (ERR) + } + fdout = reopen (fdin, READ_WRITE) + + if (XIM_DBG) { + call eprintf ("Reconnected on '%s'\n"); call pargstr (connect) + } + + # Tell the server we're ready to begin. + call sprintf (Memc[cmsg], SZ_LINE, "ready %s\0") + call pargstr (name) + msglen = strlen (Memc[cmsg]) + call xim_message ("ximtool", Memc[cmsg]) + + + # Post the xim_onerror procedure to be executed upon process shutdown + # to issue a warning to the server in case we don't close normally. + + call onerror (xim_onerror) + + call sfree (sp) + return (OK) +end + + +# XIM_DISCONNECT -- Disconnect from the currect channel. + +procedure xim_disconnect (send_quit) + +int send_quit + +# I/O common. +int fdin, fdout, mode, nbuf, nr, nw +char buffer[SZ_MESSAGE] +common /ximfd/ fdin, fdout, mode, nbuf, buffer, nr, nw + +begin + # Send a QUIT message to the server so we shut down the connection. + if (send_quit == YES) + call xim_message ("ximtool", "quit") + + call flush (fdout) # Close the socket connection. + call close (fdin) + call close (fdout) + fdin = NULL + fdout = NULL +end + + +# XIM_MESSAGE -- Send a message to an XImtool named object. If the object +# is 'ximtool' then just pass the message directly without formatting it. + +procedure xim_message (object, message) + +char object[ARB] #I object name +char message[ARB] #I message to send + +pointer sp, msgbuf +int msglen, olen, mlen, ip + +int strlen() +bool streq() + +begin + # Get the message length plus some extra for the braces and padding. + olen = strlen (object) + mlen = strlen (message) + msglen = olen + mlen + 20 + + # Allocate and clear the message buffer. + call smark (sp) + call salloc (msgbuf, msglen, TY_CHAR) + call aclrc (Memc[msgbuf], msglen) + + if (streq (object, "ximtool")) { + # Just send the message. + call strcpy (message, Memc[msgbuf], msglen) + } else { + # Format the message. We can't use a sprintf here since the + # message may be bigger than that allowed by a pargstr(). + ip = 0 + call amovc ("send ", Memc[msgbuf+ip], 5) ; ip = ip + 5 + call amovc (object, Memc[msgbuf+ip], olen) ; ip = ip + olen + call amovc (" { ", Memc[msgbuf+ip], 3) ; ip = ip + 3 + call amovc (message, Memc[msgbuf+ip], mlen) ; ip = ip + mlen + call amovc (" }\0", Memc[msgbuf+ip], 2) ; ip = ip + 3 + } + msglen = strlen (Memc[msgbuf]) + + # Now send the message. The write routine does the strpak(). + call xim_write (Memc[msgbuf], msglen) + + call sfree (sp) +end + + +# XIM_ALERT -- Send an alert message to XImtool. + +procedure xim_alert (text, ok, cancel) + +char text[ARB] #I warning text +char ok[ARB] #i client OK message +char cancel[ARB] #i client CANCEL message + +pointer sp, msg + +begin + call smark (sp) + call salloc (msg, SZ_LINE, TY_CHAR) + + call sprintf (Memc[msg], SZ_LINE, "{%s} {%s} {%s}") + call pargstr (text) + call pargstr (ok) + call pargstr (cancel) + + call xim_message ("alert", Memc[msg]) + + call sfree (sp) +end + + +# XIM_WRITE -- Low-level write of a message to the socket. Writes exactly +# len bytes to the stream. + +procedure xim_write (message, len) + +char message[ARB] #I message to send +int len #I length of message + +int nleft, n, ip +char msgbuf[SZ_MESSAGE] +int strlen() + +# I/O common. +int fdin, fdout, mode, nbuf, nr, nw +char buffer[SZ_MESSAGE] +common /ximfd/ fdin, fdout, mode, nbuf, buffer, nr, nw + +errchk write, flush + +begin + # Pad message with a NULL to terminate it. + len = strlen (message) + 1 + message[len] = '\0' + + if (mod(len,2) == 1) { + len = len + 1 + message[len] = '\0' + } + + ip = 1 + nleft = len + while (nleft > 0) { + n = min (nleft, SZ_MESSAGE) + call amovc (message[ip], msgbuf, n) + if (mode == XIM_BINARY) { + call achtcb (msgbuf, msgbuf, n) + call write (fdout, msgbuf, n / SZB_CHAR) + } else + call write (fdout, msgbuf, n) + + ip = ip + n + nleft = nleft - n + } + nw = nw + len + call flush (fdout) + + if (XIM_DBG) { + call eprintf ("xim_write: '%.45s' len=%d mode=%d tot=%d\n") + call pargstr (message);call pargi (len) + call pargi (mode); call pargi (nw) + } +end + + +# XIM_READ -- Low-level read from the socket. + +int procedure xim_read (message, len) + +char message[ARB] #O message read +int len #O length of message + +int i, n, nleft, read() + +# I/O common. +int fdin, fdout, mode, nbuf, nr, nw +char buffer[SZ_MESSAGE] +common /ximfd/ fdin, fdout, mode, nbuf, buffer, nr, nw + +# Interrupt handler variables common. +int ximepa, ximstat, old_onint, xim_fd, xim_jmp[LEN_JUMPBUF] +common /ximcom/ xim_fd, xim_jmp, ximepa, ximstat, old_onint + +errchk read + +begin + # No data left in the buffer so read from the socket + if (nbuf == 0) { + call aclrc (buffer, SZ_MESSAGE) + nbuf = 0 + + iferr { + n = read (fdin, message, SZ_MESSAGE) + if (n < 0) + return (EOF) + } then { + call xer_reset() + call zdojmp (xim_jmp, X_IPC) + } + + if (mode == XIM_BINARY) { + len = n * SZB_CHAR + call achtbc (message, message, len) + } else + len = n + + # Save the data read to a local buffer. Remove any extra + # EOS padding and append an EOF on the string. + call amovc (message, buffer, len) + if (buffer[len] == EOS && buffer[len-1] == EOS) + nbuf = len + else + nbuf = len + 1 + buffer[nbuf] = EOF + } + + for (i=1; buffer[i] != EOS && buffer[i] != EOF && i <= nbuf; i=i+1) + message[i] = buffer[i] + message[i] = '\0' + len = i # length of the current message + nleft = nbuf - i # nchars left in the buffer + nr = nr + len + + if (buffer[i] == EOS && buffer[i+1] == EOF) { + # That was the last message, force a new read next time we're + # called. + if (i > 1 && nleft > 1) + call amovc (buffer[i+1], buffer, nleft) + nbuf = 0 + } else { + # More of the message is left in the buffer. + if (nleft > 0) + call amovc (buffer[i+1], buffer, nleft) + nbuf = nleft + } + + if (XIM_DBG) { + call eprintf ("xim_read: tot=%d len=%d/%d msg='%30.30s'\n") + call pargi(nr); call pargi (len) + call pargstr(message) + call eprintf ("xim_read: nbuf=%d nleft=%d buffer='%s'\n") + call pargi (nbuf); call pargi(nleft); call pargstr(buffer) + } + + #return (len) + return (nleft) +end + + +# XIM_INTRHANDLER -- User-callable interrupt handler so the ISM client code +# doesn't need to know about our internals. + +int procedure xim_intrhandler() + +extern xim_zxwhen() + +# Interrupt handler variables common. +int ximepa, ximstat, old_onint, xim_fd, xim_jmp[LEN_JUMPBUF] +common /ximcom/ xim_fd, xim_jmp, ximepa, ximstat, old_onint + +begin + call zlocpr (xim_zxwhen, ximepa) + call xwhen (X_INT, ximepa, old_onint) + call zsvjmp (xim_jmp, ximstat) + + if (ximstat == OK) + return (OK) + else + return (ERR) +end + + +# XIM_ZXWHEN -- Interrupt handler for the Ximtool client task. Branches back +# to ZSVJMP in the user routine to permit shutdown without an error message +# after first disconnecting from the socket. + +procedure xim_zxwhen (vex, next_handler) + +int vex # virtual exception +int next_handler # not used + +# Interrupt handler variables common. +int ximepa, ximstat, old_onint, xim_fd, xim_jmp[LEN_JUMPBUF] +common /ximcom/ xim_fd, xim_jmp, ximepa, ximstat, old_onint + +begin + call xim_disconnect (YES) + call xer_reset() + call zdojmp (xim_jmp, vex) +end + + +# XIM_ONERROR -- Error exit handler for the interface. If this is a normal exit +# the shut down quietly, otherwise notify the server. + +procedure xim_onerror (status) + +int status #i not used (req. for ONEXIT) + +# Exception handler variables common. +int xim_errstat +common /ximecom/ xim_errstat + +int code +char buf[SZ_LINE], errmsg[SZ_LINE] + +int errget() + +# Interrupt handler variables common. +int ximepa, ximstat, old_onint, xim_fd, xim_jmp[LEN_JUMPBUF] +common /ximcom/ xim_fd, xim_jmp, ximepa, ximstat, old_onint + +begin + if (status != OK) { + code = errget (errmsg, SZ_LINE) + call sprintf (buf, SZ_LINE, "ISM Error, code %d:\n`%s\'") + call pargi (status) + call pargstr (errmsg) + + call xim_alert (buf, NULL, NULL) + call xim_disconnect (YES) + } +end diff --git a/vendor/x11iraf/ximtool/clients.old/lib/zfiond.c b/vendor/x11iraf/ximtool/clients.old/lib/zfiond.c new file mode 100644 index 00000000..1ae65048 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/lib/zfiond.c @@ -0,0 +1,723 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#include <sys/types.h> +#include <sys/stat.h> +#include <sys/file.h> +#include <sys/socket.h> +#include <netinet/in.h> +#include <sys/un.h> +#include <netdb.h> +#include <fcntl.h> + +#ifdef LINUX +#include <sys/time.h> +#endif + +#include <errno.h> +#include <stdio.h> + +#define import_kernel +#define import_knames +#define import_zfstat +#define import_spp +#include <iraf.h> + +/* + * ZFIOND -- This driver provides a FIO-compatible interface to network or + * IPC streaming devices such as Berkeley sockets, FIFOs, and the like. + * Any connection-oriented stream type network interface can be supported. + * + * The type of connection desired is determined at device open time by the + * "filename" and file access mode arguments. The syntax for the filename + * argument is as follows: + * + * <domain> : <address> [ : <flag ] [ : flag...] + * + * where <domain> is one of "inet" (internet tcp/ip socket), "unix" (unix + * domain socket) or "fifo" (named pipe). The form of the address depends + * upon the domain, as illustrated in the examples below. + * + * inet:5187 Server connection to port 5187 on the local + * host. For a client, a connection to the + * given port on the local host. + * + * inet:5187:foo.bar.edu Client connection to port 5187 on internet + * host foo.bar.edu. The dotted form of address + * may also be used. + * + * unix:/tmp/.IMT212 Unix domain socket with the given pathname + * IPC method, local host only. + * + * fifo:/dev/imt1i:/dev/imt1o FIFO or named pipe with the given pathname. + * IPC method, local host only. Two pathnames + * are required, one for input and one for + * output, since FIFOs are not bidirectional. + * For a client the first fifo listed will be + * the client's input fifo; for a server the + * first fifo will be the server's output fifo. + * This allows the same address to be used for + * both the client and the server, as for the + * other domains. + * + * The address field may contain up to two "%d" fields. If present, the + * user's UID will be substituted (e.g. "unix:/tmp/.IMT%d"). + * + * The only protocol flags currently supported are "text" and "binary". + * If "text" is specified the datastream is assumed to consist only of byte + * packed ascii text and is automatically converted by the driver to and + * from SPP chars during i/o. The default is binary i/o (no conversions). + * + * Client connections normally use mode READ_WRITE, although READ_ONLY and + * WRITE_ONLY are permitted. APPEND is the same as WRITE_ONLY. A server + * connection is indicated by the mode NEW_FILE. The endpoints of the server + * connection will be created if necessary. A client connection will timeout + * if no server responds. + * + * An INET or UNIX domain server connection will block indefinitely until a + * client connects. Since connections are synchronous only a single client + * can be supported. The server sees an EOF on the input stream when the + * client disconnects. + * + * FIFO domain connection are slightly different. When the server opens a FIFO + * connection the open returns immediately. When the server reads from the + * input fifo the server will block until some data is written to the fifo by a + * client. The server connection will remain open over multiple client + * connections until it is closed by the server. This is done to avoid a race + * condition that could otherwise occur at open time, with both the client and + * the server blocked waiting for an open on the opposite stream. + */ + +#define SZ_NAME 256 +#define SZ_OBUF 4096 +#define MAXCONN 5 +#define MAXSEL 32 + +#define INET 1 +#define UNIX 2 +#define FIFO 3 + +#define F_SERVER 00001 +#define F_DEL1 00002 +#define F_DEL2 00004 +#define F_TEXT 00010 + +/* Network portal descriptor. */ +struct portal { + int domain; + int flags; + int datain; + int dataout; + int keepalive; + char path1[SZ_NAME]; + char path2[SZ_NAME]; +}; + +#define get_desc(fd) ((struct portal *)zfd[fd].fp) +#define set_desc(fd,np) zfd[fd].fp = (FILE *)np +#define min(a,b) (((a)<(b))?(a):(b)) + +extern int errno; +static int getstr(); + + +/* ZOPNND -- Open a network device. + */ +ZOPNND (pk_osfn, mode, chan) +PKCHAR *pk_osfn; /* UNIX name of file */ +XINT *mode; /* file access mode */ +XINT *chan; /* file number (output) */ +{ + register int fd; + register struct portal *np; + unsigned short host_port; + unsigned long host_addr; + char osfn[SZ_NAME*2]; + char flag[SZ_NAME]; + char *ip; + + /* Get network device descriptor. */ + if (!(np = (struct portal *) calloc (1, sizeof(struct portal)))) { + *chan = XERR; + return; + } + + /* Expand any %d fields in the network address to the UID. */ + sprintf (osfn, (char *)pk_osfn, getuid(), getuid()); + + /* Parse the network filename to determine the domain type and + * network address. + */ + if (strncmp (osfn, "inet:", 5) == 0) { + /* Internet connection. + */ + char port_str[SZ_NAME]; + char host_str[SZ_NAME]; + unsigned short port; + struct servent *sv; + struct hostent *hp; + + /* Get port number. This may be specified either as a service + * name or as a decimal port number. + */ + ip = osfn + 5; + if (getstr (&ip, port_str, SZ_NAME) <= 0) + goto err; + if (isdigit (port_str[0])) { + port = atoi (port_str); + host_port = htons (port); + } else if (sv = getservbyname(port_str,"tcp")) { + host_port = sv->s_port; + } else + goto err; + + /* Get host address. This may be specified either has a host + * name or as an Internet address in dot notation. If no host + * name is specified default to the local host. + */ + if (getstr (&ip, host_str, SZ_NAME) <= 0) + strcpy (host_str, "localhost"); + if (isdigit (host_str[0])) { + host_addr = inet_addr (host_str); + if ((int)host_addr == -1) + goto err; + } else if (hp = gethostbyname(host_str)) { + bcopy (hp->h_addr, (char *)&host_addr, sizeof(host_addr)); + } else + goto err; + + np->domain = INET; + + } else if (strncmp (osfn, "unix:", 5) == 0) { + /* Unix domain socket connection. + */ + ip = osfn + 5; + if (!getstr (&ip, np->path1, SZ_NAME)) + goto err; + np->domain = UNIX; + + } else if (strncmp (osfn, "fifo:", 5) == 0) { + /* FIFO (named pipe) connection. + */ + ip = osfn + 5; + if (*mode == NEW_FILE) { + /* Server. */ + if (!getstr (&ip, np->path2, SZ_NAME)) + goto err; + if (!getstr (&ip, np->path1, SZ_NAME)) + goto err; + } else { + /* Client. */ + if (!getstr (&ip, np->path1, SZ_NAME)) + goto err; + if (!getstr (&ip, np->path2, SZ_NAME)) + goto err; + } + np->domain = FIFO; + + } else + goto err; + + /* Process any optional protocol flags. + */ + while (getstr (&ip, flag, SZ_NAME) > 0) { + /* Get content type (text or binary). If the stream will be used + * only for byte-packed character data the content type can be + * specified as "text" and data will be automatically packed and + * unpacked during i/o. + */ + if (strcmp (flag, "text") == 0) + np->flags |= F_TEXT; + if (strcmp (flag, "binary") == 0) + np->flags &= ~F_TEXT; + } + + /* Open the network connection. + */ + switch (*mode) { + case READ_ONLY: + /* Client side read only FIFO connection. */ + if (np->domain == FIFO) { + if ((fd = open (np->path1, O_RDONLY|O_NDELAY)) != ERR) + fcntl (fd, F_SETFL, O_RDONLY); + np->datain = fd; + np->dataout = -1; + break; + } + /* fall through */ + + case WRITE_ONLY: + case APPEND: + /* Client side write only FIFO connection. */ + if (np->domain == FIFO) { + if ((fd = open (np->path2, O_WRONLY|O_NDELAY)) != ERR) + fcntl (fd, F_SETFL, O_WRONLY); + np->datain = -1; + np->dataout = fd; + break; + } + /* fall through */ + + case READ_WRITE: + if (np->domain == INET) { + /* Client side Internet domain connection. */ + struct sockaddr_in sockaddr; + + /* Get socket. */ + if ((fd = socket (AF_INET, SOCK_STREAM, 0)) < 0) + goto err; + + /* Compose network address. */ + bzero ((char *)&sockaddr, sizeof(sockaddr)); + sockaddr.sin_family = AF_INET; + sockaddr.sin_port = host_port; + bcopy ((char *)&host_addr, (char *)&sockaddr.sin_addr, + sizeof(host_addr)); + + /* Connect to server. */ + if (fd >= MAXOFILES || connect (fd, + (struct sockaddr *)&sockaddr, sizeof(sockaddr)) < 0) { + close (fd); + fd = ERR; + } else { + np->datain = fd; + np->dataout = fd; + } + + } else if (np->domain == UNIX) { + /* Client side Unix domain socket connection. */ + struct sockaddr_un sockaddr; + + /* Get socket. */ + if ((fd = socket (AF_UNIX, SOCK_STREAM, 0)) < 0) + goto err; + + /* Compose network address. */ + bzero ((char *)&sockaddr, sizeof(sockaddr)); + sockaddr.sun_family = AF_UNIX; + strncpy (sockaddr.sun_path, + np->path1, sizeof(sockaddr.sun_path)); + + /* Connect to server. */ + if (fd >= MAXOFILES || connect (fd, + (struct sockaddr *)&sockaddr, sizeof(sockaddr)) < 0) { + close (fd); + fd = ERR; + } else { + np->datain = fd; + np->dataout = fd; + } + + } else if (np->domain == FIFO) { + /* Client side FIFO connection. */ + int fd1, fd2; + + /* Open the fifos. */ + if ((fd1 = open (np->path1, O_RDONLY|O_NDELAY)) != ERR) + fcntl (fd1, F_SETFL, O_RDONLY); + if ((fd2 = open (np->path2, O_WRONLY|O_NDELAY)) != ERR) + fcntl (fd2, F_SETFL, O_WRONLY); + + /* Clean up if there is an error. */ + if (fd1 < 0 || fd1 > MAXOFILES || fd2 < 0 || fd2 > MAXOFILES) { + if (fd1 > 0) + close (fd1); + if (fd2 > 0) + close (fd2); + fd = ERR; + } else { + np->datain = fd1; + np->dataout = fd2; + fd = fd1; + } + } else + goto err; + break; + + case NEW_FILE: + /* Connect to a client. */ + np->flags |= F_SERVER; + + if (np->domain == INET) { + /* Server side Internet domain connection. */ + struct sockaddr_in sockaddr; + int s, reuse=1; + + /* Get socket. */ + if ((s = socket (AF_INET, SOCK_STREAM, 0)) < 0) + goto err; + + /* Bind server port to socket. */ + bzero ((char *)&sockaddr, sizeof(sockaddr)); + sockaddr.sin_family = AF_INET; + sockaddr.sin_port = host_port; + sockaddr.sin_addr.s_addr = htonl(INADDR_ANY); + + if (setsockopt(s, SOL_SOCKET, SO_REUSEADDR, (char *)&reuse, + sizeof(reuse)) < 0) { + close (s); + goto err; + } + + if (bind (s, + (struct sockaddr *)&sockaddr, sizeof(sockaddr)) < 0) { + close (s); + goto err; + } + + /* Wait for client to connect. */ + if (listen (s, MAXCONN) < 0) { + close (s); + goto err; + } + if ((fd = accept (s, (struct sockaddr *)0, (int *)0)) < 0) { + close (s); + goto err; + } else + close (s); + + np->datain = fd; + np->dataout = fd; + + } else if (np->domain == UNIX) { + /* Server side Unix domain connection. */ + struct sockaddr_un sockaddr; + int addrlen, s; + + /* Get socket. */ + if ((s = socket (AF_UNIX, SOCK_STREAM, 0)) < 0) + goto err; + + /* Bind server port to socket. */ + bzero ((char *)&sockaddr, sizeof(sockaddr)); + sockaddr.sun_family = AF_UNIX; + strncpy (sockaddr.sun_path,np->path1,sizeof(sockaddr.sun_path)); + addrlen = sizeof(sockaddr) - sizeof(sockaddr.sun_path) + + strlen(np->path1); + + unlink (np->path1); + if (bind (s, (struct sockaddr *)&sockaddr, addrlen) < 0) { + close (s); + goto err; + } + + /* Wait for client to connect. */ + if (listen (s, MAXCONN) < 0) { + close (s); + goto err; + } + if ((fd = accept (s, (struct sockaddr *)0, (int *)0)) < 0) { + close (s); + goto err; + } else + close (s); + + np->datain = fd; + np->dataout = fd; + np->flags |= F_DEL1; + + } else if (np->domain == FIFO) { + /* Server side FIFO connection. */ + int fd1, fd2, keepalive; + + /* Create fifos if necessary. */ + if (access (np->path1, 0) < 0) { + if (mknod (np->path1, 010660, 0) < 0) + goto err; + else + np->flags |= F_DEL1; + } + if (access (np->path2, 0) < 0) { + if (mknod (np->path2, 010660, 0) < 0) { + unlink (np->path1); + goto err; + } else + np->flags |= F_DEL2; + } + + /* Open the output fifo (which is the client's input fifo). + * We have to open it ourselves first as a client to get + * around the fifo open-no-client error. + */ + if ((fd1 = open (np->path2, O_RDONLY|O_NDELAY)) != -1) { + if ((fd2 = open (np->path2, O_WRONLY|O_NDELAY)) != -1) + fcntl (fd2, F_SETFL, O_WRONLY); + close (fd1); + } + + /* Open the input fifo. */ + if ((fd1 = open (np->path1, O_RDONLY|O_NDELAY)) == -1) + fprintf (stderr, "Warning: cannot open %s\n", np->path1); + else { + /* Clear O_NDELAY for reading. */ + fcntl (fd1, F_SETFL, O_RDONLY); + + /* Open the client's output fifo as a pseudo-client to + * make it appear that a client is connected. + */ + keepalive = open (np->path1, O_WRONLY); + } + + /* Clean up if there is an error. */ + if (fd1 < 0 || fd1 > MAXOFILES || fd2 < 0 || fd2 > MAXOFILES) { + if (fd1 > 0) { + close (fd1); + close (keepalive); + } + if (fd2 > 0) + close (fd2); + fd = ERR; + } else { + np->datain = fd1; + np->dataout = fd2; + np->keepalive = keepalive; + fd = fd1; + } + + } else + goto err; + break; + + default: + fd = ERR; + } + + /* Initialize the kernel file descriptor. Seeks are illegal for a + * network device; network devices are "streaming" files (blksize=1) + * which can only be accessed sequentially. + */ + if ((*chan = fd) == ERR) { +err: free (np); + *chan = XERR; + } else if (fd >= MAXOFILES) { + free (np); + close (fd); + *chan = XERR; + } else { + zfd[fd].fp = NULL; + zfd[fd].fpos = 0L; + zfd[fd].nbytes = 0; + zfd[fd].flags = 0; + zfd[fd].filesize = 0; + set_desc(fd,np); + } +} + + +/* ZCLSND -- Close a network device. + */ +ZCLSND (fd, status) +XINT *fd; +XINT *status; +{ + register struct portal *np = get_desc(*fd); + register int flags; + + if (np) { + flags = np->flags; + + if (np->datain > 0) + close (np->datain); + if (np->dataout > 0 && np->dataout != np->datain) + close (np->dataout); + if (np->keepalive > 0) + close (np->keepalive); + + if (flags & F_DEL1) + unlink (np->path1); + if (flags & F_DEL2) + unlink (np->path2); + + free (np); + set_desc(*fd,NULL); + *status = XOK; + + } else + *status = XERR; +} + + +/* ZARDND -- "Asynchronous" binary block read. Initiate a read of at most + * maxbytes bytes from the file FD into the buffer BUF. Status is returned + * in a subsequent call to ZAWTND. + */ +ZARDND (chan, buf, maxbytes, offset) +XINT *chan; /* UNIX file number */ +XCHAR *buf; /* output buffer */ +XINT *maxbytes; /* max bytes to read */ +XLONG *offset; /* 1-indexed file offset to read at */ +{ + register int n; + int fd = *chan; + struct fiodes *kfp = &zfd[fd]; + register struct portal *np = get_desc (fd); + register char *ip; + register XCHAR *op; + int nbytes, maxread; + + /* Determine maximum amount of data to be read. */ + maxread = (np->flags & F_TEXT) ? *maxbytes/sizeof(XCHAR) : *maxbytes; + + /* The following call to select shouldn't be necessary, but it + * appears that, due to the way we open a FIFO with O_NDELAY, read + * can return zero if read is called before the process on the other + * end writes any data. This happens even though fcntl is called to + * restore blocking i/o after the open. + */ + if (np->domain == FIFO && np->datain < MAXSEL) { +#ifdef SOLARIS + fd_set readfds; + FD_ZERO (&readfds); + FD_SET (np->datain, &readfds); +#else + int readfds = (1 << np->datain); +#endif + select (MAXSEL, &readfds, NULL, NULL, NULL); + nbytes = read (np->datain, (char *)buf, maxread); + } else + nbytes = read (np->datain, (char *)buf, maxread); + + if ((n = nbytes) && (np->flags & F_TEXT)) { + op = (XCHAR *) buf; + op[n] = XEOS; + for (ip = (char *)buf; --n >= 0; ) + op[n] = ip[n]; + nbytes *= sizeof(XCHAR); + } + + kfp->nbytes = nbytes; +} + + +/* ZAWRND -- "Asynchronous" binary block write. Initiate a write of exactly + * nbytes bytes from the buffer BUF to the file FD. Status is returned in a + * subsequent call to ZAWTND. + */ +ZAWRND (chan, buf, nbytes, offset) +XINT *chan; /* UNIX file number */ +XCHAR *buf; /* buffer containing data */ +XINT *nbytes; /* nbytes to be written */ +XLONG *offset; /* 1-indexed file offset */ +{ + register int fd = *chan; + register struct fiodes *kfp = &zfd[fd]; + register struct portal *np = get_desc (fd); + int nwritten, maxbytes, n; + char *text, *ip = (char *)buf; + char obuf[SZ_OBUF]; + + maxbytes = (np->domain == FIFO || (np->flags & F_TEXT)) ? SZ_OBUF : 0; + for (nwritten=0; nwritten < *nbytes; nwritten += n, ip+=n) { + n = *nbytes - nwritten; + if (maxbytes) + n = min (maxbytes, n); + + if (np->flags & F_TEXT) { + register XCHAR *ipp = (XCHAR *)ip; + register char *op = (char *)obuf; + register int nbytes = n; + + while (--nbytes >= 0) + *op++ = *ipp++; + text = obuf; + if ((n = write (np->dataout, text, n / sizeof(XCHAR))) < 0) + break; + n *= sizeof(XCHAR); + + } else { + text = ip; + if ((n = write (np->dataout, text, n)) < 0) + break; + } + } + + kfp->nbytes = nwritten; +} + + +/* ZAWTND -- "Wait" for an "asynchronous" read or write to complete, and + * return the number of bytes read or written, or ERR. + */ +ZAWTND (fd, status) +XINT *fd; +XINT *status; +{ + if ((*status = zfd[*fd].nbytes) == ERR) + *status = XERR; +} + + +/* ZSTTND -- Return file status information for a network device. + */ +ZSTTND (fd, param, lvalue) +XINT *fd; +XINT *param; +XLONG *lvalue; +{ + register struct fiodes *kfp = &zfd[*fd]; + struct stat filstat; + + switch (*param) { + case FSTT_BLKSIZE: + (*lvalue) = 0L; + break; + + case FSTT_FILSIZE: + (*lvalue) = 0L; + break; + + case FSTT_OPTBUFSIZE: + /* On some systems this parameter may be device dependent in which + * case device dependent code should be substituted here. + */ + (*lvalue) = ND_OPTBUFSIZE; + break; + + case FSTT_MAXBUFSIZE: + /* On some systems this parameter may be device dependent in which + * case device dependent code should be substituted here. + */ + (*lvalue) = ND_MAXBUFSIZE; + break; + + default: + (*lvalue) = XERR; + break; + } +} + + +/* + * Internal routines. + * ---------------------------- + */ + +/* GETSTR -- Internal routine to extract a colon delimited string from a + * network filename. + */ +static int +getstr (ipp, obuf, maxch) +char **ipp; +char *obuf; +int maxch; +{ + register char *ip = *ipp, *op = obuf; + register char *otop = obuf + maxch; + char *start; + + while (isspace(*ip)) + ip++; + for (start=ip; *ip; ip++) { + if (*ip == ':') { + ip++; + break; + } else if (op && op < otop) + *op++ = *ip; + } + + if (op) + *op = '\0'; + *ipp = ip; + + return (ip - start); +} diff --git a/vendor/x11iraf/ximtool/clients.old/mkpkg b/vendor/x11iraf/ximtool/clients.old/mkpkg new file mode 100644 index 00000000..3b50a906 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/mkpkg @@ -0,0 +1,34 @@ +# Make the ISM Client tasks. + +$call relink +$exit + +update: + $call relink + $call install + ; + +relink: + $set LIBS = "-lslalib" + $update libpkg.a + $omake x_ism.x + $link -z x_ism.o libpkg.a -o ism_wcspix.e $(LIBS) + ; + +debug: + $set LIBS = "-lslalib" + $set XFLAGS = "$(XFLAGS) -xqF" + $update libpkg.a + $omake x_ism.x + $link -z -x x_ism.o libpkg.a -o ism_wcspix.e $(LIBS) + ; + +install: + $move ism_wcspix.e ../../bin/ism_wcspix.e + ; + + +libpkg.a: + @lib + @wcspix + ; diff --git a/vendor/x11iraf/ximtool/clients.old/wcspix/README b/vendor/x11iraf/ximtool/clients.old/wcspix/README new file mode 100644 index 00000000..e69de29b --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/wcspix/README diff --git a/vendor/x11iraf/ximtool/clients.old/wcspix/class.com b/vendor/x11iraf/ximtool/clients.old/wcspix/class.com new file mode 100644 index 00000000..c6116c11 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/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.old/wcspix/mkpkg b/vendor/x11iraf/ximtool/clients.old/wcspix/mkpkg new file mode 100644 index 00000000..baa3b090 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/wcspix/mkpkg @@ -0,0 +1,15 @@ +# 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 + wcmef.x wcspix.h + wcmspec.x wcspix.h + wcunknown.x wcspix.h + ; + diff --git a/vendor/x11iraf/ximtool/clients.old/wcspix/t_wcspix.f b/vendor/x11iraf/ximtool/clients.old/wcspix/t_wcspix.f new file mode 100644 index 00000000..a1fce8a5 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/wcspix/t_wcspix.f @@ -0,0 +1,1124 @@ + subroutine twcspx () + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer wp + integer len + integer discot + integer ncmd + integer*2 socket(255 +1) + integer*2 cmd(255 +1) + integer*2 messae(1023 +1) + integer*2 buf(12 +1) + integer objid + integer regid + real x + real y + integer*2 ref(255 +1) + integer*2 temple(1023 +1) + integer*2 param(255 +1) + logical debug + integer*4 clktie + integer wpinit + integer envges + integer envgei + integer strdic + integer ximcot + integer wpread + integer ximinr + logical xerpop + logical xerflg + common /xercom/ xerflg + integer sw0001 + integer*2 st0001(7) + integer*2 st0002(17) + integer*2 st0003(7) + integer*2 st0004(5) + integer*2 st0005(13) + integer*2 st0006(28) + integer*2 st0007(8) + integer*2 st0008(22) + integer*2 st0009(73) + integer*2 st0010(31) + integer*2 st0011(35) + integer*2 st0012(41) + integer*2 st0013(8) + integer*2 st0014(16) + integer*2 st0015(38) + integer*2 st0016(8) + integer*2 st0017(25) + integer*2 st0018(16) + integer*2 st0019(27) + integer*2 st0020(30) + save + integer iyy + data st0001 / 73, 83, 77, 68, 69, 86, 0/ + data (st0002(iyy),iyy= 1, 8) /117,110,105,120, 58, 47,116,109/ + data (st0002(iyy),iyy= 9,16) /112, 47, 46, 73, 83, 77, 37,100/ + data (st0002(iyy),iyy=17,17) / 0/ + data st0003 /119, 99,115,112,105,120, 0/ + data st0004 /116,101,120,116, 0/ + data (st0005(iyy),iyy= 1, 8) / 87, 67, 83, 80, 73, 88, 95, 68/ + data (st0005(iyy),iyy= 9,13) / 69, 66, 85, 71, 0/ + data (st0006(iyy),iyy= 1, 8) /105,110,102,111, 32,123, 32, 37/ + data (st0006(iyy),iyy= 9,16) /115, 58, 32, 87, 67, 83, 80, 73/ + data (st0006(iyy),iyy=17,24) / 88, 32, 67,111,110,110,101, 99/ + data (st0006(iyy),iyy=25,28) /116,125, 10, 0/ + data st0007 /105,115,109, 95,109,115,103, 0/ + data (st0008(iyy),iyy= 1, 8) /109,101,115,115, 97,103,101, 58/ + data (st0008(iyy),iyy= 9,16) / 32, 39, 37,115, 39, 32,108,101/ + data (st0008(iyy),iyy=17,22) /110, 61, 37,100, 10, 0/ + data (st0009(iyy),iyy= 1, 8) /124,115,101,116,124,103,101,116/ + data (st0009(iyy),iyy= 9,16) /124,113,117,105,116,124,105,110/ + data (st0009(iyy),iyy=17,24) /105,116,105, 97,108,105,122,101/ + data (st0009(iyy),iyy=25,32) /124, 99, 97, 99,104,101,124,117/ + data (st0009(iyy),iyy=33,40) /110, 99, 97, 99,104,101, 9, 9/ + data (st0009(iyy),iyy=41,48) / 9, 32,124,119, 99,115,116,114/ + data (st0009(iyy),iyy=49,56) / 97,110,124,119, 99,115,108,105/ + data (st0009(iyy),iyy=57,64) /115,116,124,111, 98,106,105,110/ + data (st0009(iyy),iyy=65,72) /102,111,124,100,101, 98,117,103/ + data (st0009(iyy),iyy=73,73) / 0/ + data (st0010(iyy),iyy= 1, 8) /105,110,102,111, 32,123, 32, 37/ + data (st0010(iyy),iyy= 9,16) /115, 58, 32, 87, 67, 83, 80, 73/ + data (st0010(iyy),iyy=17,24) / 88, 32, 73,110,105,116,105, 97/ + data (st0010(iyy),iyy=25,31) /108,105,122,101,125, 10, 0/ + data (st0011(iyy),iyy= 1, 8) / 99, 97, 99,104,101, 58, 32,111/ + data (st0011(iyy),iyy= 9,16) / 98,106,105,100, 61, 37,100, 32/ + data (st0011(iyy),iyy=17,24) /114,101,103,105,100, 61, 37,100/ + data (st0011(iyy),iyy=25,32) / 32,114,101,102, 61, 39, 37,115/ + data (st0011(iyy),iyy=33,35) / 39, 10, 0/ + data (st0012(iyy),iyy= 1, 8) /105,110,102,111, 32,123, 32, 37/ + data (st0012(iyy),iyy= 9,16) /115, 58, 32, 87, 67, 83, 80, 73/ + data (st0012(iyy),iyy=17,24) / 88, 32, 67, 97, 99,104,101, 32/ + data (st0012(iyy),iyy=25,32) / 32, 32,111, 98,106,105,100, 61/ + data (st0012(iyy),iyy=33,40) / 37, 51,100, 32, 37,115,125, 10/ + data (st0012(iyy),iyy=41,41) / 0/ + data st0013 /105,115,109, 95,109,115,103, 0/ + data (st0014(iyy),iyy= 1, 8) /117,110, 99, 97, 99,104,101, 58/ + data (st0014(iyy),iyy= 9,16) / 32,105,100, 61, 37,100, 10, 0/ + data (st0015(iyy),iyy= 1, 8) /105,110,102,111, 32,123, 32, 37/ + data (st0015(iyy),iyy= 9,16) /115, 58, 32, 87, 67, 83, 80, 73/ + data (st0015(iyy),iyy=17,24) / 88, 32, 85,110, 99, 97, 99,104/ + data (st0015(iyy),iyy=25,32) /101, 32,111, 98,106,105,100, 61/ + data (st0015(iyy),iyy=33,38) / 37, 51,100,125, 10, 0/ + data st0016 /105,115,109, 95,109,115,103, 0/ + data (st0017(iyy),iyy= 1, 8) /119, 99,115,116,114, 97,110, 58/ + data (st0017(iyy),iyy= 9,16) / 32,105,100, 61, 37,100, 32, 32/ + data (st0017(iyy),iyy=17,24) / 40, 37,103, 44, 37,103, 41, 10/ + data (st0017(iyy),iyy=25,25) / 0/ + data (st0018(iyy),iyy= 1, 8) /119, 99,115,108,105,115,116, 58/ + data (st0018(iyy),iyy= 9,16) / 32,105,100, 61, 37,100, 10, 0/ + data (st0019(iyy),iyy= 1, 8) /111, 98,106,105,110,102,111, 58/ + data (st0019(iyy),iyy= 9,16) / 32,105,100, 61, 37,100, 32, 32/ + data (st0019(iyy),iyy=17,24) /116,101,109,112, 61, 39, 37,115/ + data (st0019(iyy),iyy=25,27) / 39, 10, 0/ + data (st0020(iyy),iyy= 1, 8) / 73, 83, 77, 32,100,101,102, 97/ + data (st0020(iyy),iyy= 9,16) /117,108,116, 58, 32,108,101,110/ + data (st0020(iyy),iyy=17,24) / 61, 37,100, 32,109,115,103, 61/ + data (st0020(iyy),iyy=25,30) / 39, 37,115, 39, 10, 0/ + call aclrc (messae, 1023 ) + call aclrc (cmd, 255 ) + call aclrc (socket, 255 ) + if (.not.(envges (st0001, socket, 255 ) .le. 0).and.(.not. + * xerflg)) goto 110 + if (xerflg) goto 100 + call xstrcy(st0002, socket, 255 ) +110 continue + if (.not.(ximcot (socket, st0003, st0004) .eq. -1)) goto 120 + goto 100 +120 continue + if (.not.(ximinr() .eq. -1)) goto 130 + goto 100 +130 continue + wp = wpinit () + call xerpsh + memi(wp+6) = envgei (st0005) + if (.not.xerpop()) goto 140 + memi(wp+6) = 0 +140 continue + call wpcnve (clktie(0), buf, 12 ) + call sprinf (messae, 1023 , st0006) + call pargsr (buf) + call ximmee (st0007, messae) + discot = 1 + debug = (.false. .or. memi(wp+6) .gt. 0) +150 if (.not.(wpread (messae, len) .ne. -2).and.(.not.xerflg)) goto + * 151 + if (xerflg) goto 100 + if (.not.(debug)) goto 160 + call eprinf(st0008) + call pargsr (messae) + call pargi (len) +160 continue + if (.not.(len .le. 0)) goto 170 + discot = 0 + goto 151 +170 continue + call sscan (messae) + call gargwd (cmd, 1023 ) + ncmd = strdic (cmd, cmd, 1023 , st0009) + sw0001=(ncmd) + goto 180 +190 continue + discot = 0 + goto 151 +200 continue + call wpcnve (clktie(0), buf, 12 ) + call sprinf (messae, 1023 , st0010) + call pargsr (buf) + call wpinie (wp) + goto 181 +210 continue + call gargwd (ref, 255 ) + call gargi (objid) + call gargi (regid) + if (.not.(debug)) goto 220 + call xprinf(st0011) + call pargi(objid) + call pargi(regid) + call pargsr(ref) +220 continue + call wpcnve (clktie(0), buf, 12 ) + call sprinf (messae, 1023 , st0012) + call pargsr (buf) + call pargi (objid) + call pargsr (ref) + call ximmee (st0013, messae) + call wpcace (wp, objid, regid, ref) + goto 181 +230 continue + call gargi (objid) + if (.not.(debug)) goto 240 + call xprinf(st0014) + call pargi(objid) +240 continue + call wpcnve (clktie(0), buf, 12 ) + call sprinf (messae, 1023 , st0015) + call pargsr (buf) + call pargi (objid) + call ximmee (st0016, messae) + call wpunce (wp, objid) + goto 181 +250 continue + call gargi (objid) + call gargr (x) + call gargr (y) + if (.not.(debug)) goto 260 + call xprinf(st0017) + call pargi(objid) + call pargr (x) + call pargr (y) +260 continue + call wpwcsn (wp, objid, x, y) + goto 181 +270 continue + call gargi (objid) + if (.not.(debug)) goto 280 + call xprinf(st0018) + call pargi(objid) +280 continue + call wpwcst (wp, objid) + goto 181 +290 continue + call gargi (objid) + call gargwd (temple, 255 ) + if (.not.(debug)) goto 300 + call xprinf(st0019) + call pargi(objid) + call pargsr (temple) +300 continue + call wpobjo (wp, objid, temple) + goto 181 +310 continue + call gargwd (param, 255 ) + call wpsetr (wp, param) + goto 181 +320 continue + goto 181 +330 continue + debug = .not.(debug) + goto 181 +340 continue + if (.not.(debug)) goto 350 + call eprinf (st0020) + call pargi(len) + call pargsr(messae) +350 continue + goto 181 +180 continue + if (sw0001.lt.1.or.sw0001.gt.10) goto 340 + goto (310,320,190,200,210,230,250,270,290,330),sw0001 +181 continue + call aclrc (messae, 1023 ) + goto 150 +151 continue + call ximdit (discot) + call wpshun (wp) +100 return + end + subroutine wpinie (wp) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer wp + integer cp + integer wpid2j + integer i + save + i=0 +110 if (.not.(i .lt. 256 )) goto 112 + cp = wpid2j (wp, i) + if (.not.(cp .ne. 0 .and. memi(cp) .ne. 0)) goto 120 + call wpunce (wp, memi(cp) ) +120 continue +111 i=i+1 + goto 110 +112 continue +100 return + end + subroutine wpcace (wp, objid, regid, ref) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer wp + integer objid + integer regid + integer*2 ref(*) + integer cp + integer i + integer class + integer*2 alert(255 +1) + integer wpclas + integer clncls + integer cltabe(6 ,16 ) + integer*2 clnams(32 +1,16 ) + common /classm/ clncls, cltabe, clnams + integer*2 st0001(29) + integer*2 st0002(1) + integer*2 st0003(1) + save + integer iyy + data (st0001(iyy),iyy= 1, 8) /119,112, 95, 99, 97, 99,104,101/ + data (st0001(iyy),iyy= 9,16) / 58, 32, 85,110, 97, 98,108,101/ + data (st0001(iyy),iyy=17,24) / 32,116,111, 32, 99, 97, 99,104/ + data (st0001(iyy),iyy=25,29) /101, 10, 37,115, 0/ + data st0002 / 0/ + data st0003 / 0/ + i=0 +110 if (.not.(i .lt. 256 )) goto 112 + cp = memi(memi(wp ) +i) + if (.not.(memi(cp+4) .eq. 0)) goto 120 + goto 112 +120 continue +111 i=i+1 + goto 110 +112 continue + class = wpclas (ref) + if (.not.(class .eq. -1)) goto 130 + call sprinf (alert, 255 , st0001) + call pargsr (ref) + call ximalt (alert, st0002, st0003) + goto 100 +130 continue + memi(cp+2) = class + if (.not.(class .ne. 0 .and. cltabe(1,class) .ne. 0)) goto 140 + call zcall2 (cltabe(1,class) , cp, wp) +140 continue + if (.not.(class .ne. 0 .and. cltabe(2,class) .ne. 0)) goto 150 + call zcall4 (cltabe(2,class) , cp, objid, regid, ref) +150 continue +100 return + end + subroutine wpunce (wp, id) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer wp + integer id + integer cp + integer wpid2j + integer class + integer clncls + integer cltabe(6 ,16 ) + integer*2 clnams(32 +1,16 ) + common /classm/ clncls, cltabe, clnams + save + cp = wpid2j (wp, id) + if (.not.(cp .eq. 0)) goto 110 + goto 100 +110 continue + class = memi(cp+2) + if (.not.(class .ne. 0 .and. cltabe(3,class) .ne. 0)) goto 120 + call zcall2 (cltabe(3,class) , cp, id) +120 continue + memi(cp+4) = 0 +100 return + end + subroutine wpwcsn (wp, id, x, y) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer wp + integer id + real x + real y + integer cp + integer wpid2j + integer class + integer clncls + integer cltabe(6 ,16 ) + integer*2 clnams(32 +1,16 ) + common /classm/ clncls, cltabe, clnams + save + cp = wpid2j (wp, id) + if (.not.(cp .eq. 0)) goto 110 + goto 100 +110 continue + class = memi(cp+2) + if (.not.(class .ne. 0 .and. cltabe(4,class) .ne. 0)) goto 120 + call zcall4 (cltabe(4,class) , cp, id, x, y) +120 continue +100 return + end + subroutine wpwcst (wp, id) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer wp + integer id + integer cp + integer wpid2j + integer class + integer clncls + integer cltabe(6 ,16 ) + integer*2 clnams(32 +1,16 ) + common /classm/ clncls, cltabe, clnams + save + cp = wpid2j (wp, id) + if (.not.(cp .eq. 0)) goto 110 + goto 100 +110 continue + class = memi(cp+2) + if (.not.(class .ne. 0 .and. cltabe(5,class) .ne. 0)) goto 120 + call zcall2 (cltabe(5,class) , cp, id) +120 continue +100 return + end + subroutine wpobjo (wp, id, temple) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer wp + integer id + integer*2 temple(*) + integer cp + integer wpid2j + integer class + integer clncls + integer cltabe(6 ,16 ) + integer*2 clnams(32 +1,16 ) + common /classm/ clncls, cltabe, clnams + save + cp = wpid2j (wp, id) + if (.not.(cp .eq. 0)) goto 110 + goto 100 +110 continue + class = memi(cp+2) + if (.not.(class .ne. 0 .and. cltabe(6,class) .ne. 0)) goto 120 + call zcall3 (cltabe(6,class) , cp, id, temple) +120 continue +100 return + end + subroutine wpsetr (wp, param) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer wp + integer*2 param(255 +1) + integer*2 arg(32 +1) + integer*2 buf(32 +1) + integer*2 msg(32 +1) + integer line + integer strdic + integer clncls + integer cltabe(6 ,16 ) + integer*2 clnams(32 +1,16 ) + integer sw0001,sw0002,sw0003 + common /classm/ clncls, cltabe, clnams + integer*2 st0001(11) + integer*2 st0002(23) + integer*2 st0003(4) + integer*2 st0004(4) + integer*2 st0005(66) + integer*2 st0006(12) + integer*2 st0007(14) + integer*2 st0008(30) + integer*2 st0009(12) + integer*2 st0010(13) + save + integer iyy + data (st0001(iyy),iyy= 1, 8) /115,101,116, 58, 32, 37,115, 32/ + data (st0001(iyy),iyy= 9,11) / 61, 32, 0/ + data (st0002(iyy),iyy= 1, 8) /124,112,115,105,122,101,124, 98/ + data (st0002(iyy),iyy= 9,16) /112,109,124,119, 99,115,124,102/ + data (st0002(iyy),iyy=17,23) /111,114,109, 97,116,124, 0/ + data st0003 / 37,100, 10, 0/ + data st0004 / 37,100, 10, 0/ + data (st0005(iyy),iyy= 1, 8) /124,110,111,110,101,124,108,111/ + data (st0005(iyy),iyy= 9,16) /103,105, 99, 97,108,124,112,104/ + data (st0005(iyy),iyy=17,24) /121,115,105, 99, 97,108,124,119/ + data (st0005(iyy),iyy=25,32) /111,114,108,100,124,115,107,121/ + data (st0005(iyy),iyy=33,40) / 9, 9, 9,124, 97,109,112,108/ + data (st0005(iyy),iyy=41,48) /105,102,105,101,114,124, 99, 99/ + data (st0005(iyy),iyy=49,56) /100,124,100,101,116,101, 99,116/ + data (st0005(iyy),iyy=57,64) /111,114,124,111,116,104,101,114/ + data (st0005(iyy),iyy=65,66) /124, 0/ + data (st0006(iyy),iyy= 1, 8) / 37,115, 32,108,105,110,101, 61/ + data (st0006(iyy),iyy= 9,12) / 37,100, 10, 0/ + data (st0007(iyy),iyy= 1, 8) /119, 99,115,116,121,112,101, 32/ + data (st0007(iyy),iyy= 9,14) / 37,115, 32, 37,100, 0/ + data (st0008(iyy),iyy= 1, 8) /124,100,101,102, 97,117,108,116/ + data (st0008(iyy),iyy= 9,16) /124,104,109,115,124,100,101,103/ + data (st0008(iyy),iyy=17,24) /114,101,101,115,124,114, 97,100/ + data (st0008(iyy),iyy=25,30) /105, 97,110,115,124, 0/ + data (st0009(iyy),iyy= 1, 8) / 37,115, 32,108,105,110,101, 61/ + data (st0009(iyy),iyy= 9,12) / 37,100, 10, 0/ + data (st0010(iyy),iyy= 1, 8) /119, 99,115,102,109,116, 32, 37/ + data (st0010(iyy),iyy= 9,13) /115, 32, 37,100, 0/ + if (.not.(.false.)) goto 110 + call xprinf(st0001) + call pargsr(param) +110 continue + sw0001=(strdic (param, param, 32 , st0002)) + goto 120 +130 continue + call gargi (memi(wp+1) ) + if (.not.(.false.)) goto 140 + call xprinf(st0003) + call pargi(memi(wp+1) ) +140 continue + goto 121 +150 continue + call gargi (memi(wp+2) ) + if (.not.(.false.)) goto 160 + call xprinf(st0004) + call pargi(memi(wp+2) ) +160 continue + goto 121 +170 continue + call gargwd (buf, 255 ) + call gargi (line) + call xstrcy(buf, arg, 32 ) + call strlwr (buf) + sw0002=(strdic (buf, buf, 255 , st0005)) + goto 180 +190 continue + memi(memi(wp+3) +line-1) = 2 + goto 181 +200 continue + memi(memi(wp+3) +line-1) = 3 + goto 181 +210 continue + memi(memi(wp+3) +line-1) = 4 + goto 181 +220 continue + memi(memi(wp+3) +line-1) = 1 + goto 181 +230 continue + memi(memi(wp+3) +line-1) = 6 + goto 181 +240 continue + memi(memi(wp+3) +line-1) = 3 + goto 181 +250 continue + memi(memi(wp+3) +line-1) = 8 + goto 181 +260 continue + memi(memi(wp+3) +line-1) = 5 + goto 181 +180 continue + if (sw0002.lt.1.or.sw0002.gt.8) goto 260 + goto (220,190,200,210,260,230,240,250),sw0002 +181 continue + call xstrcy(buf, memc(memi(wp+4) +(32 *(line-1))), 32 ) + if (.not.(.false.)) goto 270 + call xprinf(st0006) + call pargsr(buf) + call pargi(line) +270 continue + call sprinf (msg, 255 , st0007) + call pargsr (arg) + call pargi (line) + call wcspie (msg) + goto 121 +280 continue + call gargwd (buf, 255 ) + call gargi (line) + call xstrcy(buf, arg, 32 ) + call strlwr (buf) + sw0003=(strdic (buf, buf, 255 , st0008)) + goto 290 +300 continue + memi(memi(wp+5) +line-1) = 1 + goto 291 +310 continue + memi(memi(wp+5) +line-1) = 2 + goto 291 +320 continue + memi(memi(wp+5) +line-1) = 3 + goto 291 +330 continue + memi(memi(wp+5) +line-1) = 4 + goto 291 +340 continue + memi(memi(wp+5) +line-1) = 1 + goto 291 +290 continue + if (sw0003.lt.1.or.sw0003.gt.4) goto 340 + goto (300,310,320,330),sw0003 +291 continue + if (.not.(.false.)) goto 350 + call xprinf(st0009) + call pargsr(buf) + call pargi(line) +350 continue + call sprinf (msg, 255 , st0010) + call pargsr (arg) + call pargi (line) + call wcspie (msg) + goto 121 +120 continue + if (sw0001.lt.1.or.sw0001.gt.4) goto 121 + goto (130,150,170,280),sw0001 +121 continue +100 return + end + subroutine wpgetr (wp, param) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer wp + integer*2 param(255 +1) + integer strdic + integer sw0001 + integer*2 st0001(11) + integer*2 st0002(23) + save + integer iyy + data (st0001(iyy),iyy= 1, 8) /115,101,116, 58, 32, 37,115, 32/ + data (st0001(iyy),iyy= 9,11) / 61, 32, 0/ + data (st0002(iyy),iyy= 1, 8) /124,112,115,105,122,101,124, 98/ + data (st0002(iyy),iyy= 9,16) /112,109,124,119, 99,115,124,102/ + data (st0002(iyy),iyy=17,23) /111,114,109, 97,116,124, 0/ + if (.not.(.false.)) goto 110 + call xprinf(st0001) + call pargsr(param) +110 continue + sw0001=(strdic (param, param, 32 , st0002)) + goto 120 +130 continue + goto 121 +140 continue + goto 121 +150 continue + goto 121 +160 continue + goto 121 +120 continue + if (sw0001.lt.1.or.sw0001.gt.4) goto 121 + goto (130,140,150,160),sw0001 +121 continue +100 return + end + integer function wpinit () + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer wp + integer i + logical xerpop + logical xerflg + common /xercom/ xerflg + integer*2 st0001(37) + integer*2 st0002(5) + save + integer iyy + data (st0001(iyy),iyy= 1, 8) / 69,114,114,111,114, 32,111,112/ + data (st0001(iyy),iyy= 9,16) /101,110,105,110,103, 32, 87, 67/ + data (st0001(iyy),iyy=17,24) / 83, 80, 73, 88, 32,116, 97,115/ + data (st0001(iyy),iyy=25,32) /107, 32,115,116,114,117, 99,116/ + data (st0001(iyy),iyy=33,37) /117,114,101, 46, 0/ + data st0002 /110,111,110,101, 0/ + call xerpsh + call xcallc(wp, 7, 10 ) + if (.not.xerpop()) goto 110 + call xerror(0, st0001) + if (xerflg) goto 100 +110 continue + call xcallc(memi(wp+3) , 4 , 4) + call xcallc(memi(wp+5) , 4 , 4) + call xcallc(memi(wp+4) , (32 *4 ), 2) + i=1 +120 if (.not.(i .le. 4 )) goto 122 + memi(memi(wp+5) +i-1) = 1 + memi(memi(wp+3) +i-1) = 2 + call xstrcy(st0002, memc(memi(wp+4) +(32 *(i-1))), 32 ) +121 i=i+1 + goto 120 +122 continue + call xcallc(memi(wp ) , 256 , 10 ) + i=0 +130 if (.not.(i .lt. 256 )) goto 132 + call xcallc(memi(memi(wp ) +i) , 135 , 10 ) +131 i=i+1 + goto 130 +132 continue + memi(wp+1) = 0 + memi(wp+2) = 1 + call wpclat() + wpinit = (wp) + goto 100 +100 return + end + integer function wpread (messae, len) + integer len + integer*2 messae(*) + integer nread + integer ximred + logical xerflg + common /xercom/ xerflg + save + nread = ximred (messae, len) + if (xerflg) goto 100 + wpread = (nread) + goto 100 +100 return + end + subroutine wpshun (wp) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer wp + integer i + save + call xmfree(memi(wp+4) , 2) + call xmfree(memi(wp+5) , 4) + call xmfree(memi(wp+3) , 4) + i=0 +110 if (.not.(i .lt. 256 )) goto 112 + call xmfree(memi(memi(wp ) +i) , 10 ) +111 i=i+1 + goto 110 +112 continue + call xmfree(memi(wp ) , 10 ) + call xmfree(wp, 10 ) +100 return + end + integer function wpclas (object) + integer*2 object(*) + integer n + integer class + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer im + integer*2 ch + integer*2 buf(255 +1) + integer xstrln + integer stridx + logical streq + integer immap + logical xerpop + logical xerflg + common /xercom/ xerflg + integer*2 st0001(9) + integer*2 st0002(8) + save + integer iyy + data (st0001(iyy),iyy= 1, 8) / 47,100,101,118, 47,112,105,120/ + data (st0001(iyy),iyy= 9, 9) / 0/ + data st0002 /100,101,118, 36,112,105,120, 0/ + call imgime (object, buf, 255 ) + n = xstrln(buf) - 7 + if (.not.(streq (buf(n), st0001))) goto 110 + call xstrcy(st0002, buf, 255 ) + ch = 91 + n = stridx (ch, object) + if (.not.(n .gt. 0)) goto 120 + call xstrct(object(n), buf, 255 ) +120 continue + call xstrcy(buf, object, 255 ) +110 continue + class = 1 + call xerpsh + im = immap (object, 1 , 0) + if (xerpop()) goto 130 + class = 2 + call imunmp (im) +130 continue + wpclas = (class) + goto 100 +100 return + end + integer function wpid2j (wp, id) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer wp + integer id + integer i + integer cp + save + i=0 +110 if (.not.(i .lt. 256 )) goto 112 + cp = memi(memi(wp ) +i) + if (.not.(memi(cp) .eq. id)) goto 120 + wpid2j = (cp) + goto 100 +120 continue +111 i=i+1 + goto 110 +112 continue + wpid2j = (0) + goto 100 +100 return + end + subroutine wpclat () + external imgint + external imgcae + external imgune + external imgwcn + external imgwct + external imgobo + external mefint + external mefcae + external mefune + external mefwcn + external mefwct + external mefobo + external mspint + external mspcae + external mspune + external mspwcn + external mspwct + external mspobo + external unkint + external unkcae + external unkune + external unkwcn + external unkwct + external unkobo + integer clncls + integer cltabe(6 ,16 ) + integer*2 clnams(32 +1,16 ) + integer locpr + common /classm/ clncls, cltabe, clnams + integer*2 st0001(8) + integer*2 st0002(6) + integer*2 st0003(4) + integer*2 st0004(10) + save + integer iyy + data st0001 /117,110,107,110,111,119,110, 0/ + data st0002 /105,109, 97,103,101, 0/ + data st0003 /109,101,102, 0/ + data (st0004(iyy),iyy= 1, 8) /109,117,108,116,105,115,112,101/ + data (st0004(iyy),iyy= 9,10) / 99, 0/ + clncls = 0 + call wploas (st0001, locpr(unkint), locpr(unkcae), locpr(unkune + * ), locpr(unkwcn), locpr(unkwct), locpr(unkobo)) + call wploas (st0002, locpr(imgint), locpr(imgcae), locpr(imgune + * ), locpr(imgwcn), locpr(imgwct), locpr(imgobo)) + call wploas (st0003, locpr(mefint), locpr(mefcae), locpr(mefune + * ), locpr(mefwcn), locpr(mefwct), locpr(mefobo)) + call wploas (st0004, locpr(mspint), locpr(mspcae), locpr(mspune + * ), locpr(mspwcn), locpr(mspwct), locpr(mspobo)) +100 return + end + subroutine wploas (name, init, cache, uncace, tran, list, info) + integer init + integer cache + integer uncace + integer tran + integer list + integer info + integer*2 name(*) + integer clncls + integer cltabe(6 ,16 ) + integer*2 clnams(32 +1,16 ) + logical xerflg + common /xercom/ xerflg + common /classm/ clncls, cltabe, clnams + save + if (.not.(clncls + 1 .gt. 16 )) goto 110 + goto 100 +110 continue + clncls = clncls + 1 + cltabe(1,clncls) = init + cltabe(2,clncls) = cache + cltabe(3,clncls) = uncace + cltabe(4,clncls) = tran + cltabe(5,clncls) = list + cltabe(6,clncls) = info + call xstrcy(name, clnams(1,clncls) , 255 ) +100 return + end + subroutine wcspie (messae) + integer*2 messae(*) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer sp + integer msgbuf + integer msglen + integer mlen + integer ip + integer xstrln + integer*2 st0001(18) + integer*2 st0002(4) + integer*2 st0003(8) + save + integer iyy + data (st0001(iyy),iyy= 1, 8) /100,101,108,105,118,101,114, 32/ + data (st0001(iyy),iyy= 9,16) /119, 99,115,112,105,120, 32,123/ + data (st0001(iyy),iyy=17,18) / 32, 0/ + data st0002 / 32,125, 0, 0/ + data st0003 /105,115,109, 95,109,115,103, 0/ + mlen = xstrln(messae) + msglen = mlen + 64 + call smark (sp) + call salloc (msgbuf, msglen, 2) + call aclrc (memc(msgbuf), msglen) + ip = 0 + call amovc (st0001, memc(msgbuf), 17) + ip = ip + 17 + call amovc (messae, memc(msgbuf+ip), mlen) + ip = ip + mlen + call amovc (st0002, memc(msgbuf+ip), 2) + ip = ip + 2 + call ximmee (st0003, memc(msgbuf)) + call sfree (sp) +100 return + end + subroutine wpcnve (ltime, outstr, maxch) + integer*4 ltime + integer maxch + integer*2 outstr(*) + integer tm(8 ) + integer*2 st0001(14) + save + integer iyy + data (st0001(iyy),iyy= 1, 8) / 37, 50,100, 58, 37, 48, 50,100/ + data (st0001(iyy),iyy= 9,14) / 58, 37, 48, 50,100, 0/ + call brktie (ltime, tm) + call sprinf (outstr, maxch, st0001) + call pargi (tm(3) ) + call pargi (tm(2) ) + call pargi (tm(1) ) +100 return + end + subroutine dbgpre (wp, buf) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer wp + integer*2 buf(*) + integer cp + integer wpid2j + integer i + integer*2 st0001(4) + integer*2 st0002(23) + save + integer iyy + data st0001 / 37,115, 10, 0/ + data (st0002(iyy),iyy= 1, 8) / 37, 51,100, 58, 32, 32,105,100/ + data (st0002(iyy),iyy= 9,16) / 61, 37,100, 32, 32,114,101,102/ + data (st0002(iyy),iyy=17,23) / 61, 39, 37,115, 39, 10, 0/ + call xprinf(st0001) + call pargsr (buf) + i=0 +110 if (.not.(i .lt. 256 )) goto 112 + cp = wpid2j (wp, i) + if (.not.(memi(cp+3) .ne. 0)) goto 120 + call xprinf(st0002) + call pargi(i) + call pargi(memi(cp) ) + call pargsr(memc((((cp+6)-1)*2+1)) ) +120 continue +111 i=i+1 + goto 110 +112 continue +100 return + end +c temple template +c sprinf sprintf +c wpclas wp_class +c clncls cl_nclass +c wcspie wcspix_message +c classm class_com +c unkwct unk_wcslist +c mefcae mef_cache +c mspwct msp_wcslist +c cltabe cl_table +c unkint unk_init +c wpread wp_read +c mspint msp_init +c ximmee xim_message +c wpcace wp_cache +c imgcae img_cache +c messae message +c unkobo unk_objinfo +c mspobo msp_objinfo +c clktie clktime +c ximcot xim_connect +c wpshun wp_shutdown +c wpclat wp_class_init +c imgime imgimage +c mefune mef_uncache +c mefwcn mef_wcstran +c ximinr xim_intrhandler +c clnams cl_names +c gargwd gargwrd +c ximalt xim_alert +c brktie brktime +c twcspx t_wcspix +c wpunce wp_uncache +c wpwcsn wp_wcstran +c imgune img_uncache +c imgwcn img_wcstran +c envgei envgeti +c wpgetr wp_getpar +c mefwct mef_wcslist +c wpinie wp_initialize +c ximred xim_read +c mefint mef_init +c unkcae unk_cache +c wpwcst wp_wcslist +c imunmp imunmap +c imgwct img_wcslist +c mspcae msp_cache +c eprinf eprintf +c wpinit wp_init +c imgint img_init +c mefobo mef_objinfo +c envges envgets +c ximdit xim_disconnect +c discot disconnect +c dbgpre dbg_printcache +c wpcnve wp_cnvdate +c wpsetr wp_setpar +c wpid2j wp_id2obj +c wpobjo wp_objinfo +c imgobo img_objinfo +c unkune unk_uncache +c unkwcn unk_wcstran +c wploas wp_load_class +c uncace uncache +c pargsr pargstr +c mspune msp_uncache +c mspwcn msp_wcstran diff --git a/vendor/x11iraf/ximtool/clients.old/wcspix/t_wcspix.x b/vendor/x11iraf/ximtool/clients.old/wcspix/t_wcspix.x new file mode 100644 index 00000000..675fb57a --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/wcspix/t_wcspix.x @@ -0,0 +1,769 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <ctype.h> +include <time.h> +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 +int len, disconnect, ncmd +char socket[SZ_FNAME], cmd[SZ_FNAME], message[SZ_LINE], buf[SZ_DATE] + +int objid, regid +real x, y +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 xim_connect(), wp_read(), xim_intrhandler() +errchk wp_read, envgets, envgeti + +begin + call aclrc (message, SZ_LINE) + call aclrc (cmd, SZ_FNAME) + call aclrc (socket, SZ_FNAME) + + # 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 (xim_connect (socket, WCSPIX_NAME, WCSPIX_MODE) == ERR) + return + + # Install an interrupt exception handler so we can exit cleanly. + if (xim_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 xim_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 (message, len) != EOF) { + + if (debug) { + 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: + # <ref> <objid> <regid> + 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 xim_message ("ism_msg", message) + + call wp_cache (wp, objid, regid, ref) + + case UNCACHE: + # <id> + 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 xim_message ("ism_msg", message) + + call wp_uncache (wp, objid) + + case WCSTRAN: + # <id> <x> <y> [[<region> <x> <y>] ["NDC" <x> <y> ]] + 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: + # <id> + call gargi (objid) + if (debug) { call printf ("wcslist: id=%d\n");call pargi(objid)} + call wp_wcslist (wp, objid) + + case OBJINFO: + # <id> <template_list> + 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: + # <param> <value> + call gargwrd (param, SZ_FNAME) + call wp_setpar (wp, param) + + case GET: + # <param> + + 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 xim_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 xim_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_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) = DEF_PTABSZ + 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 (message, len) + +char message[ARB] #o message buffer +int len #o length of message + +int nread + +int xim_read() # low-level i/o +errchk xim_read + +begin + nread = xim_read (message, len) + + return (nread) +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 xim_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.old/wcspix/wcimage.f b/vendor/x11iraf/ximtool/clients.old/wcspix/wcimage.f new file mode 100644 index 00000000..116b7106 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/wcspix/wcimage.f @@ -0,0 +1,1975 @@ + subroutine imgint (cp, wp) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer cp + integer wp + integer img + logical xerpop + logical xerflg + common /xercom/ xerflg + integer*2 st0001(12) + save + integer iyy + data (st0001(iyy),iyy= 1, 8) /105,109,103, 95,105,110,105,116/ + data (st0001(iyy),iyy= 9,12) / 58, 32, 10, 0/ + if (.not.(.false.)) goto 110 + call xprinf(st0001) +110 continue + if (.not.(memi(cp+3) .eq. 0)) goto 120 + call xerpsh + call xcallc(memi(cp+3) , 15, 10 ) + if (.not.xerpop()) goto 130 + goto 100 +130 continue +120 continue + img = memi(cp+3) + memi(img ) = wp + memi(img+1) = 0 + memi(img+3) = 0 + memi(img+4) = 0 + memi(img+5) = 0 + memi(img+6) = 0 + memr(img+9) = 0.0 + memr(img+10) = 0.0 + memi(img+11) = 1 +100 return + end + subroutine imgcae (cp, objid, regid, ref) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer cp + integer objid + integer regid + integer*2 ref(*) + integer img + integer im + integer wp + integer stat + integer*2 alert(1023 +1) + integer immap + integer dspmmp + integer mwsctn + integer imgams + integer imgdes + integer imaccf + integer skdecm + logical xerpop + logical xerflg + common /xercom/ xerflg + integer*2 st0001(13) + integer*2 st0002(19) + integer*2 st0003(1) + integer*2 st0004(1) + integer*2 st0005(6) + integer*2 st0006(8) + integer*2 st0007(6) + integer*2 st0008(8) + integer*2 st0009(9) + integer*2 st0010(7) + integer*2 st0011(7) + integer*2 st0012(5) + integer*2 st0013(5) + integer*2 st0014(7) + integer*2 st0015(7) + integer*2 st0016(5) + integer*2 st0017(5) + integer*2 st0018(30) + integer*2 st0019(1) + integer*2 st0020(1) + integer*2 st0021(4) + save + integer iyy + data (st0001(iyy),iyy= 1, 8) /105,109,103, 95, 99, 97, 99,104/ + data (st0001(iyy),iyy= 9,13) /101, 58, 32, 10, 0/ + data (st0002(iyy),iyy= 1, 8) / 85,110, 97, 98,108,101, 32,116/ + data (st0002(iyy),iyy= 9,16) /111, 32, 99, 97, 99,104,101, 10/ + data (st0002(iyy),iyy=17,19) / 37,115, 0/ + data st0003 / 0/ + data st0004 / 0/ + data st0005 /119,111,114,108,100, 0/ + data st0006 /108,111,103,105, 99, 97,108, 0/ + data st0007 /119,111,114,108,100, 0/ + data st0008 /108,111,103,105, 99, 97,108, 0/ + data (st0009(iyy),iyy= 1, 8) /112,104,121,115,105, 99, 97,108/ + data (st0009(iyy),iyy= 9, 9) / 0/ + data st0010 / 65, 84, 77, 49, 95, 49, 0/ + data st0011 / 65, 84, 77, 50, 95, 50, 0/ + data st0012 / 65, 84, 86, 49, 0/ + data st0013 / 65, 84, 86, 50, 0/ + data st0014 / 68, 84, 77, 49, 95, 49, 0/ + data st0015 / 68, 84, 77, 50, 95, 50, 0/ + data st0016 / 68, 84, 86, 49, 0/ + data st0017 / 68, 84, 86, 50, 0/ + data (st0018(iyy),iyy= 1, 8) / 85,110, 97, 98,108,101, 32,116/ + data (st0018(iyy),iyy= 9,16) /111, 32,100,101, 99,111,100,101/ + data (st0018(iyy),iyy=17,24) / 32,105,109, 97,103,101, 32, 87/ + data (st0018(iyy),iyy=25,30) / 67, 83, 10, 37,115, 0/ + data st0019 / 0/ + data st0020 / 0/ + data st0021 / 66, 80, 77, 0/ + if (.not.(.false.)) goto 110 + call xprinf(st0001) +110 continue + img = memi(cp+3) + wp = memi(img ) + call xerpsh + memi(img+1) = immap (ref, 1 , 0) + if (.not.xerpop()) goto 120 + call sprinf (alert, 255 , st0002) + call pargsr (ref) + call ximalt (alert, st0003, st0004) + goto 100 +120 continue + memi(img+4) = 0 + memi(img+5) = 0 + memi(img+6) = 0 + call xerpsh + stat = skdecm (memi(img+1) , st0005, memi(img+3) , memi(img+4) + * ) + if (xerflg) goto 132 + if (.not.(stat .eq. -1 .or. memi(img+3) .eq. 0)) goto 140 + memi(img+11) = 1 +140 continue + if (.not.(memi(img+3) .ne. 0)) goto 150 + memi(img+5) = mwsctn (memi(img+3) , st0006, st0007, 3) + if (xerflg) goto 132 + memi(img+6) = mwsctn (memi(img+3) , st0008, st0009, 3) + if (xerflg) goto 132 + im = memi(img+1) + if (.not.(imaccf(im,st0010) .eq. 1 .and. imaccf(im,st0011) . + * eq. 1 .and. imaccf(im,st0012) .eq. 1 .and. imaccf(im,st0013) + * .eq. 1)) goto 160 + memi(img+7) = imgams (im, memi(img+3) ) +160 continue + if (.not.(imaccf(im,st0014) .eq. 1 .and. imaccf(im,st0015) . + * eq. 1 .and. imaccf(im,st0016) .eq. 1 .and. imaccf(im,st0017) + * .eq. 1)) goto 170 + memi(img+8) = imgdes (im, memi(img+3) ) +170 continue +150 continue +132 if (.not.xerpop()) goto 130 + call sprinf (alert, 255 , st0018) + call pargsr (ref) + call ximalt (alert, st0019, st0020) + memi(img+11) = 1 +130 continue + if (.not.(memi(wp+2) .eq. 1)) goto 180 + call xerpsh + memi(img+2) = dspmmp (st0021, memi(img+1) ) + if (.not.xerpop()) goto 190 + memi(img+2) = 0 +190 continue +180 continue + memi(cp) = objid + memi(cp+1) = regid + memi(cp+4) = memi(cp+4) + 1 + call xstrcy(ref, memc((((cp+6)-1)*2+1)) , 128) +100 return + end + subroutine imgune (cp, id) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer cp + integer id + integer img + integer*2 st0001(15) + integer*2 st0002(1) + save + integer iyy + data (st0001(iyy),iyy= 1, 8) /105,109,103, 95,117,110, 99, 97/ + data (st0001(iyy),iyy= 9,15) / 99,104,101, 58, 32, 10, 0/ + data st0002 / 0/ + if (.not.(.false.)) goto 110 + call xprinf(st0001) +110 continue + memi(cp) = 0 + memi(cp+4) = 0 + call xstrcy(st0002, memc((((cp+6)-1)*2+1)) , 255 ) + img = memi(cp+3) + if (.not.(memi(img+3) .ne. 0)) goto 120 + call mwcloe (memi(img+3) ) +120 continue + if (.not.(memi(img+2) .ne. 0)) goto 130 + call imunmp (memi(img+2) ) +130 continue + if (.not.(memi(img+1) .ne. 0)) goto 140 + call imunmp (memi(img+1) ) +140 continue + memi(img+1) = 0 + memi(img+2) = 0 + memi(img+3) = 0 + memi(img+5) = 0 + memi(img+6) = 0 + memi(img+4) = 0 + memr(img+9) = 0.0 + memr(img+10) = 0.0 + memi(img+11) = 0 + call xmfree(memi(cp+3) , 10 ) + memi(cp+3) = 0 +100 return + end + subroutine imgwcn (cp, id, x, y) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer cp + integer id + real x + real y + integer img + integer im + integer wp + integer co + double precision dx + double precision dy + double precision wx + double precision wy + double precision pixval + real rx + real ry + integer i + integer bpm + integer*2 buf(1023 +1) + integer*2 msg(1023 +1) + integer*2 wcs(32 +1) + integer*2 xc(32 +1) + integer*2 yc(32 +1) + integer*2 xunits(32 +1) + integer*2 yunits(32 +1) + double precision skstad + integer*2 st0001(15) + integer*2 st0002(37) + integer*2 st0003(29) + integer*2 st0004(41) + save + integer iyy + data (st0001(iyy),iyy= 1, 8) /105,109,103, 95,119, 99,115,116/ + data (st0001(iyy),iyy= 9,15) /114, 97,110, 58, 32, 10, 0/ + data (st0002(iyy),iyy= 1, 8) /119, 99,115,116,114, 97,110, 32/ + data (st0002(iyy),iyy= 9,16) /123, 32,111, 98,106,101, 99,116/ + data (st0002(iyy),iyy=17,24) / 32, 37,100, 32,125, 32,123, 32/ + data (st0002(iyy),iyy=25,32) /114,101,103,105,111,110, 32, 37/ + data (st0002(iyy),iyy=33,37) /100, 32,125, 32, 0/ + data (st0003(iyy),iyy= 1, 8) /123, 32,112,105,120,118, 97,108/ + data (st0003(iyy),iyy= 9,16) / 32, 37, 57, 46, 57,103, 32,125/ + data (st0003(iyy),iyy=17,24) / 32,123, 32, 98,112,109, 32, 37/ + data (st0003(iyy),iyy=25,29) /100, 32,125, 10, 0/ + data (st0004(iyy),iyy= 1, 8) /123, 99,111,111,114,100, 32,123/ + data (st0004(iyy),iyy= 9,16) / 37, 57,115,125, 32,123, 37, 49/ + data (st0004(iyy),iyy=17,24) / 50,115,125, 32,123, 37, 49, 50/ + data (st0004(iyy),iyy=25,32) /115,125, 32,123, 37, 52,115,125/ + data (st0004(iyy),iyy=33,40) / 32,123, 37, 52,115,125,125, 10/ + data (st0004(iyy),iyy=41,41) / 0/ + if (.not.(.false.)) goto 110 + call xprinf(st0001) +110 continue + img = memi(cp+3) + co = memi(img+4) + wp = memi(img ) + im = memi(img+1) + dx = (dble(x) - skstad(co,1)) / skstad(co,3) + dy = (dble(y) - skstad(co,2)) / skstad(co,4) + rx = dx + ry = dy + call imggea (cp, id, rx, ry, pixval, bpm) + call aclrc (msg, 1023 ) + call sprinf (msg, 1023 , st0002) + call pargi (memi(cp) ) + call pargi (memi(cp+1) ) + call sprinf (buf, 1023 , st0003) + call pargd (pixval) + call pargi (bpm) + call xstrct(buf, msg, 1023 ) + i=1 +120 if (.not.(i .le. 4 )) goto 122 + call imgged (img, dx, dy, memi(memi(wp+3) +i-1), memc(memi( + * wp+4) +(32 *(i-1))), wx, wy) + call imgcos (cp, i, wcs, xunits, yunits) + call imgcot (cp, i, wx, wy, xc, yc) + call sprinf (buf, 1023 , st0004) + call pargsr (wcs) + call pargsr (xc) + call pargsr (yc) + call pargsr (xunits) + call pargsr (yunits) + call xstrct(buf, msg, 1023 ) +121 i=i+1 + goto 120 +122 continue + call wcspie (msg) +100 return + end + subroutine imgwct (cp, id) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer cp + integer id + integer img + integer im + integer mw + integer*2 msg(1023 +1) + integer*2 st0001(15) + integer*2 st0002(43) + integer*2 st0003(12) + integer*2 st0004(11) + integer*2 st0005(6) + integer*2 st0006(7) + integer*2 st0007(60) + integer*2 st0008(2) + save + integer iyy + data (st0001(iyy),iyy= 1, 8) /105,109,103, 95,119, 99,115,108/ + data (st0001(iyy),iyy= 9,15) /105,115,116, 58, 32, 10, 0/ + data (st0002(iyy),iyy= 1, 8) /119, 99,115,108,105,115,116, 32/ + data (st0002(iyy),iyy= 9,16) /123, 78,111,110,101, 32, 76,111/ + data (st0002(iyy),iyy=17,24) /103,105, 99, 97,108, 32, 87,111/ + data (st0002(iyy),iyy=25,32) /114,108,100, 32, 80,104,121,115/ + data (st0002(iyy),iyy=33,40) /105, 99, 97,108, 32,108,105,110/ + data (st0002(iyy),iyy=41,43) /101, 32, 0/ + data (st0003(iyy),iyy= 1, 8) / 32, 65,109,112,108,105,102,105/ + data (st0003(iyy),iyy= 9,12) /101,114, 32, 0/ + data (st0004(iyy),iyy= 1, 8) / 32, 68,101,116,101, 99,116,111/ + data (st0004(iyy),iyy= 9,11) /114, 32, 0/ + data st0005 / 32, 67, 67, 68, 32, 0/ + data st0006 / 32,108,105,110,101, 32, 0/ + data (st0007(iyy),iyy= 1, 8) / 70, 75, 53, 32, 70, 75, 52, 32/ + data (st0007(iyy),iyy= 9,16) / 73, 67, 82, 83, 32, 71, 65, 80/ + data (st0007(iyy),iyy=17,24) / 80, 84, 32, 70, 75, 52, 45, 78/ + data (st0007(iyy),iyy=25,32) / 79, 45, 69, 32, 69, 99,108,105/ + data (st0007(iyy),iyy=33,40) /112,116,105, 99, 32, 71, 97,108/ + data (st0007(iyy),iyy=41,48) / 97, 99,116,105, 99, 32, 83,117/ + data (st0007(iyy),iyy=49,56) /112,101,114,103, 97,108, 97, 99/ + data (st0007(iyy),iyy=57,60) /116,105, 99, 0/ + data st0008 /125, 0/ + if (.not.(.false.)) goto 110 + call xprinf(st0001) +110 continue + img = memi(cp+3) + mw = memi(img+3) + im = memi(img+1) + call xstrcy(st0002, msg, 1023 ) + if (.not.(memi(img+7) .ne. 0)) goto 120 + call xstrct(st0003, msg, 1023 ) +120 continue + if (.not.(memi(img+8) .ne. 0)) goto 130 + call xstrct(st0004, msg, 1023 ) +130 continue + if (.not.(memi(img+7) .ne. 0 .or. memi(img+8) .ne. 0)) goto 140 + call xstrct(st0005, msg, 1023 ) +140 continue + call xstrct(st0006, msg, 1023 ) + if (.not.(mw .ne. 0)) goto 150 + call xstrct(st0007, msg, 1023 ) +150 continue + call xstrct(st0008, msg, 1023 ) + call wcspie (msg) +100 return + end + subroutine imggea (cp, id, x, y, pixval, bpmpix) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer cp + integer id + real x + real y + double precision pixval + integer bpmpix + integer img + integer wp + integer im + integer bpm + integer pix + integer nl + integer nc + integer ix + integer iy + integer size + integer x1 + integer x2 + integer y1 + integer y2 + integer imgs2r + integer imgs2i + integer*2 st0001(16) + save + integer iyy + data (st0001(iyy),iyy= 1, 8) /105,109,103, 95,103,101,116, 95/ + data (st0001(iyy),iyy= 9,16) /100, 97,116, 97, 58, 32, 10, 0/ + if (.not.(.false.)) goto 110 + call xprinf(st0001) +110 continue + img = memi(cp+3) + wp = memi(img ) + im = memi(img+1) + bpm = memi(img+2) + nc = meml(im+200 +1+8-1) + nl = meml(im+200 +2+8-1) + size = memi(wp+1) + if (.not.(x .lt. 0.0 .or. y .lt. 0.0 .or. x .gt. nc .or. y .gt. + * nl)) goto 120 + goto 100 +120 continue + ix = int (x + 0.5) + iy = int (y + 0.5) + ix = max (size/2+1, ix) + iy = max (size/2+1, iy) + ix = min (ix, (nc-(size/2)-1)) + iy = min (iy, (nl-(size/2)-1)) + x1 = ix - size / 2 + 0.5 + x2 = ix + size / 2 + 0.5 + y1 = iy - size / 2 + 0.5 + y2 = iy + size / 2 + 0.5 + x1 = max (1, x1) + x2 = min (nc, x2) + y1 = max (1, y1) + y2 = min (nl, y2) + pix = imgs2r (im, int(x1), int(x2), int(y1), int(y2)) + if (.not.(bpm .ne. 0 .and. memi(wp+2) .eq. 1)) goto 130 + bpmpix = memi(imgs2i (bpm, ix, ix, iy, iy)) + goto 131 +130 continue + bpmpix = 0 +131 continue + pixval = memr(pix + ((size/2)*size) + (size/2)) * 1.0d0 + if (.not.(memi(wp+1) .gt. 1)) goto 140 + call imgseb (memr(pix), memi(wp+1) , x1, x2, y1, y2) +140 continue +100 return + end + subroutine imgobo (cp, id, temple) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer cp + integer id + integer*2 temple(*) + integer im + integer img + integer*2 st0001(15) + integer*2 st0002(7) + integer*2 st0003(7) + integer*2 st0004(96) + save + integer iyy + data (st0001(iyy),iyy= 1, 8) /105,109,103, 95,111, 98,106,105/ + data (st0001(iyy),iyy= 9,15) /110,102,111, 58, 32, 10, 0/ + data st0002 /105,109,103,104,100,114, 0/ + data st0003 /119, 99,115,104,100,114, 0/ + data (st0004(iyy),iyy= 1, 8) / 87, 67, 83, 68, 73, 77, 44, 67/ + data (st0004(iyy),iyy= 9,16) / 84, 89, 80, 69, 42, 44, 67, 82/ + data (st0004(iyy),iyy=17,24) / 80, 73, 88, 42, 44, 67, 82, 86/ + data (st0004(iyy),iyy=25,32) / 65, 76, 42, 44, 67, 68, 42, 44/ + data (st0004(iyy),iyy=33,40) / 67, 82, 79, 84, 65, 50, 44, 76/ + data (st0004(iyy),iyy=41,48) / 84, 86, 42, 44, 76, 84, 77, 42/ + data (st0004(iyy),iyy=49,56) / 44, 87, 83, 86, 42, 44, 87, 65/ + data (st0004(iyy),iyy=57,64) / 84, 42, 44, 82, 65, 42, 44, 68/ + data (st0004(iyy),iyy=65,72) / 69, 67, 42, 44, 69, 81, 85, 73/ + data (st0004(iyy),iyy=73,80) / 78, 79, 88, 44, 69, 80, 79, 67/ + data (st0004(iyy),iyy=81,88) / 72, 44, 77, 74, 68, 42, 44, 68/ + data (st0004(iyy),iyy=89,96) / 65, 84, 69, 45, 79, 66, 83, 0/ + if (.not.(.false.)) goto 110 + call xprinf(st0001) +110 continue + img = memi(cp+3) + im = memi(img+1) + call imgser (im, st0002, temple) + call imgser (im, st0003, st0004) + call imgseo (im, cp) + call imgses (im, cp) +100 return + end + subroutine imgser (im, object, temple) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer im + integer*2 object(*) + integer*2 temple(*) + integer sp + integer hdr + integer lbuf + integer line + integer field + integer keyw + integer dict + integer ip + integer lp + integer list + integer nlines + integer in + integer out + integer i + integer hdrsie + logical keywfr + integer stropn + integer getlie + integer stridx + integer imgnfn + integer strdic + integer imofnu + logical streq + logical xerflg + common /xercom/ xerflg + integer*2 st0001(5) + integer*2 st0002(2) + integer*2 st0003(2) + integer*2 st0004(2) + integer*2 st0005(3) + integer*2 st0006(2) + integer*2 st0007(5) + integer*2 st0008(2) + integer*2 st0009(11) + save + integer iyy + data st0001 / 37,115, 32,123, 0/ + data st0002 / 42, 0/ + data st0003 /124, 0/ + data st0004 /124, 0/ + data st0005 / 91,123, 0/ + data st0006 /125, 0/ + data st0007 / 37,115, 32,123, 0/ + data st0008 /125, 0/ + data (st0009(iyy),iyy= 1, 8) / 37,100, 32,123, 32, 10, 10, 10/ + data (st0009(iyy),iyy= 9,11) / 32,125, 0/ + hdrsie = (200 + memi(im+30) - (200 +1024 ) ) * 2 - 1 + hdrsie = hdrsie + 1023 + call smark (sp) + call salloc (hdr, hdrsie, 2) + call salloc (dict, hdrsie, 2) + call salloc (field, 1023 , 2) + call salloc (lbuf, 1023 , 2) + call salloc (line, 1023 , 2) + call salloc (keyw, 8, 2) + in = stropn (memc((im+(200 +1024 ) -1)*2 + 1), hdrsie, 1 ) + if (xerflg) goto 100 + out = stropn (memc(hdr), hdrsie, 3) + if (xerflg) goto 100 + call fprinf (out, st0001) + call pargsr (object) + keywfr = (.not.streq (temple, st0002)) + if (.not.(keywfr)) goto 110 + list = imofnu (im, temple) + if (xerflg) goto 100 + call xstrcy(st0003, memc(dict), hdrsie) +120 if (.not.(imgnfn (list, memc(field), 255 ) .ne. -2).and.(. + * not.xerflg)) goto 121 + if (xerflg) goto 100 + call xstrct(memc(field), memc(dict), hdrsie) + call xstrct(st0004, memc(dict), hdrsie) + goto 120 +121 continue + call imcfnl (list) +110 continue + nlines = 0 +130 if (.not.(getlie (in, memc(lbuf)) .ne. -2).and.(.not.xerflg)) + * goto 131 + if (xerflg) goto 100 + call aclrc (memc(line), 1023 ) + ip = lbuf + lp = line +140 if (.not.(memc(ip) .ne. 0 .and. memc(ip) .ne. 10)) goto 141 + if (.not.(stridx (memc(ip), st0005) .gt. 0)) goto 150 + memc(lp) = 92 + lp = lp + 1 +150 continue + memc(lp) = memc(ip) + ip = ip + 1 + lp = lp + 1 + goto 140 +141 continue + memc(lp) = 10 + memc(lp+1) = 0 + if (.not.(keywfr)) goto 160 + i=0 +170 if (.not.(i .lt. 8 .and. .not.(memc(line+i).eq.32.or.memc + * (line+i).eq.9))) goto 172 + memc(keyw+i) = memc(line+i) +171 i=i+1 + goto 170 +172 continue + memc(keyw+i) = 0 + if (.not.(strdic (memc(keyw), memc(keyw), 8, memc(dict)) + * .eq. 0).and.(.not.xerflg)) goto 180 + if (xerflg) goto 100 + goto 130 +180 continue +160 continue + call putci (out, 32) + if (xerflg) goto 100 + call putlie (out, memc(line)) + if (xerflg) goto 100 + nlines = nlines + 1 + if (.not.(mod(nlines,10) .eq. 0)) goto 190 + call fprinf (out, st0006) + call xfcloe(out) + call wcspie (memc(hdr)) + call aclrc (memc(hdr), hdrsie) + out = stropn (memc(hdr), hdrsie, 3) + if (xerflg) goto 100 + call fprinf (out, st0007) + call pargsr (object) +190 continue + goto 130 +131 continue + call fprinf (out, st0008) + call xfcloe(in) + call xfcloe(out) + call wcspie (memc(hdr)) + call sprinf (memc(hdr), 1023 , st0009) + call pargsr (object) + call wcspie (memc(hdr)) + call sfree (sp) +100 return + end + subroutine imgses (im, cp) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer im + integer cp + integer sp + integer buf + integer img + integer co + double precision cx + double precision cy + double precision cx1 + double precision cy1 + double precision dx + double precision dy + double precision x1 + double precision y1 + double precision cosa + double precision sina + double precision angle + integer i + integer j + integer compx + integer compy + integer*4 axis(7 ) + integer*4 lv(7 ) + integer*4 pv1(7 ) + integer*4 pv2(7 ) + integer*2 st0001(24) + integer*2 st0002(4) + integer*2 st0003(4) + save + integer iyy + data (st0001(iyy),iyy= 1, 8) / 99,111,109,112, 97,115,115, 32/ + data (st0001(iyy),iyy= 9,16) / 37,100, 32, 37,103, 32, 37,100/ + data (st0001(iyy),iyy=17,24) / 32, 37,100, 32, 37,115, 0, 0/ + data st0002 / 69, 32, 78, 0/ + data st0003 / 88, 32, 89, 0/ + call smark (sp) + call salloc (buf, 1023 , 2) + call aclrc (memc(buf), 1023 ) + img = memi(cp+3) + co = memi(img+4) + if (.not.(memi(img+5) .ne. 0)) goto 110 + if (.not.(memr(img+9) .gt. 0.0)) goto 120 + angle = -memr(img+9) + goto 121 +120 continue + angle = memr(img+9) + 360.0 +121 continue + cosa = cos (((angle)/57.295779513082320877)) + sina = sin (((angle)/57.295779513082320877)) + cx = meml(im+200 +1+8-1) / 2.0d0 + cy = meml(im+200 +2+8-1) / 2.0d0 + call mwc2td (memi(img+5) , cx, cy, cx1, cy1) + dx = cx + ( 10.0 * sina) + dy = cy + ( 10.0 * cosa) + call mwc2td (memi(img+5) , dx, dy, x1, y1) + if (.not.(y1 .ge. cy1)) goto 130 + compy = 1 + goto 131 +130 continue + compy = -1 +131 continue + dx = cx + (-10.0 * cosa) + dy = cy + ( 10.0 * sina) + call mwc2td (memi(img+5) , dx, dy, x1, y1) + if (.not.(x1 .ge. cx1)) goto 140 + compx = 1 + goto 141 +140 continue + compx = -1 +141 continue + goto 111 +110 continue + 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 150 j = 1, 7 + if (.not.(pv1(j) .ne. pv2(j))) goto 160 + axis(i) = j + i = i + 1 +160 continue +150 continue +151 continue + compx = - (pv2(axis(1)) - pv1(axis(1))) + compy = (pv2(axis(2)) - pv1(axis(2))) +111 continue + call sprinf (memc(buf), 1023 , st0001) + call pargi (memi(cp) ) + call pargr (memr(img+9) ) + call pargi (compx) + call pargi (compy) + if (.not.(memi(img+3) .ne. 0)) goto 170 + call pargsr (st0002) + goto 171 +170 continue + call pargsr (st0003) +171 continue + call wcspie (memc(buf)) + call sfree (sp) +100 return + end + subroutine imgseo (im, cp) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer im + integer cp + integer sp + integer co + integer img + integer mw + integer buf + integer proj + integer radecr + integer fd + integer radecs + integer ctype + integer wtype + integer ndim + double precision crpix1 + double precision crpix2 + double precision crval1 + double precision crval2 + double precision cval1 + double precision cval2 + double precision xscale + double precision yscale + double precision xrot + double precision yrot + double precision r(7 ) + double precision w(7 ) + double precision cd(7 ,7 ) + integer idxstr + integer skstai + integer stropn + integer mwstai + double precision skstad + double precision slepj + double precision slepb + logical fpequd + integer sw0001,sw0002 + logical xerflg + common /xercom/ xerflg + integer*2 st0001(21) + integer*2 st0002(15) + integer*2 st0003(15) + integer*2 st0004(29) + integer*2 st0005(15) + integer*2 st0006(15) + integer*2 st0007(30) + integer*2 st0008(4) + integer*2 st0009(114) + integer*2 st0010(8) + integer*2 st0011(11) + integer*2 st0012(52) + integer*2 st0013(11) + integer*2 st0014(9) + integer*2 st0015(1) + integer*2 st0016(9) + integer*2 st0017(1) + integer*2 st0018(14) + integer*2 st0019(1) + integer*2 st0020(7) + integer*2 st0021(1) + integer*2 st0022(25) + integer*2 st0023(41) + integer*2 st0024(53) + integer*2 st0025(4) + integer*2 st0026(4) + integer*2 st0027(4) + integer*2 st0028(4) + integer*2 st0029(53) + integer*2 st0030(4) + integer*2 st0031(4) + integer*2 st0032(4) + integer*2 st0033(4) + integer*2 st0034(58) + integer*2 st0035(55) + integer*2 st0036(57) + integer*2 st0037(2) + integer*2 st0038(2) + integer*2 st0039(2) + integer*2 st0040(2) + integer*2 st0041(2) + integer*2 st0042(2) + integer*2 st0043(25) + integer*2 st0044(7) + save + integer iyy + data (st0001(iyy),iyy= 1, 8) / 87, 67, 83, 32, 73,110,102,111/ + data (st0001(iyy),iyy= 9,16) / 58, 10, 61, 61, 61, 61, 61, 61/ + data (st0001(iyy),iyy=17,21) / 61, 61, 61, 10, 0/ + data (st0002(iyy),iyy= 1, 8) / 82, 32,116,101,114,109, 58, 32/ + data (st0002(iyy),iyy= 9,15) / 37,103, 32, 37,103, 10, 0/ + data (st0003(iyy),iyy= 1, 8) / 87, 32,116,101,114,109, 58, 32/ + data (st0003(iyy),iyy= 9,15) / 37,103, 32, 37,103, 10, 0/ + data (st0004(iyy),iyy= 1, 8) / 32, 32, 32, 32, 99,100, 58, 32/ + data (st0004(iyy),iyy= 9,16) / 37,103, 32, 37,103, 10, 32, 32/ + data (st0004(iyy),iyy=17,24) / 32, 32, 32, 32, 32, 32, 37,103/ + data (st0004(iyy),iyy=25,29) / 32, 37,103, 10, 0/ + data (st0005(iyy),iyy= 1, 8) / 32,115, 99, 97,108,101, 58, 32/ + data (st0005(iyy),iyy= 9,15) / 37,103, 32, 37,103, 10, 0/ + data (st0006(iyy),iyy= 1, 8) / 32, 32, 32,114,111,116, 58, 32/ + data (st0006(iyy),iyy= 9,15) / 37,103, 32, 37,103, 10, 0/ + data (st0007(iyy),iyy= 1, 8) /124,102,107, 52,124,102,107, 52/ + data (st0007(iyy),iyy= 9,16) / 45,110,111, 45,101,124,102,107/ + data (st0007(iyy),iyy=17,24) / 53,124,105, 99,114,115,124,103/ + data (st0007(iyy),iyy=25,30) / 97,112,112,116,124, 0/ + data st0008 / 70, 75, 53, 0/ + data (st0009(iyy),iyy= 1, 8) /124,108,105,110,124, 97,122,112/ + data (st0009(iyy),iyy= 9,16) /124,116, 97,110,124,115,105,110/ + data (st0009(iyy),iyy=17,24) /124,115,116,103,124, 97,114, 99/ + data (st0009(iyy),iyy=25,32) /124,122,112,110,124,122,101, 97/ + data (st0009(iyy),iyy=33,40) /124, 97,105,114,124, 99,121,112/ + data (st0009(iyy),iyy=41,48) /124, 99, 97,114,124,109,101,114/ + data (st0009(iyy),iyy=49,56) /124, 99,101, 97,124, 99,111,112/ + data (st0009(iyy),iyy=57,64) /124, 99,111,100,124, 99,111,101/ + data (st0009(iyy),iyy=65,72) /124, 99,111,111,124, 98,111,110/ + data (st0009(iyy),iyy=73,80) /124,112, 99,111,124,103,108,115/ + data (st0009(iyy),iyy=81,88) /124,112, 97,114,124, 97,105,116/ + data (st0009(iyy),iyy=89,96) /124,109,111,108,124, 99,115, 99/ + data (st0009(iyy),iyy=97,104) /124,113,115, 99,124,116,115, 99/ + data (st0009(iyy),iyy=105,112) /124,116,110,120,124,122,112,120/ + data (st0009(iyy),iyy=113,114) /124, 0/ + data st0010 /108,111,103,105, 99, 97,108, 0/ + data (st0011(iyy),iyy= 1, 8) /119, 99,115,105,110,102,111, 32/ + data (st0011(iyy),iyy= 9,11) /123, 10, 0/ + data (st0012(iyy),iyy= 1, 8) / 32, 32, 32, 32, 32, 32, 80,114/ + data (st0012(iyy),iyy= 9,16) /111,106,101, 99,116,105,111,110/ + data (st0012(iyy),iyy=17,24) / 58, 32, 32, 37, 45, 54,115, 9/ + data (st0012(iyy),iyy=25,32) / 32, 32, 32, 32, 32, 32, 32, 32/ + data (st0012(iyy),iyy=33,40) / 32, 32, 32, 32, 83,121,115,116/ + data (st0012(iyy),iyy=41,48) /101,109, 58, 32, 32, 37,115, 32/ + data (st0012(iyy),iyy=49,52) / 37,115, 10, 0/ + data (st0013(iyy),iyy= 1, 8) / 69,113,117, 97,116,111,114,105/ + data (st0013(iyy),iyy= 9,11) / 97,108, 0/ + data (st0014(iyy),iyy= 1, 8) / 69, 99,108,105,112,116,105, 99/ + data (st0014(iyy),iyy= 9, 9) / 0/ + data st0015 / 0/ + data (st0016(iyy),iyy= 1, 8) / 71, 97,108, 97, 99,116,105, 99/ + data (st0016(iyy),iyy= 9, 9) / 0/ + data st0017 / 0/ + data (st0018(iyy),iyy= 1, 8) / 83,117,112,101,114, 71, 97,108/ + data (st0018(iyy),iyy= 9,14) / 97, 99,116,105, 99, 0/ + data st0019 / 0/ + data st0020 / 76,105,110,101, 97,114, 0/ + data st0021 / 0/ + data (st0022(iyy),iyy= 1, 8) / 32, 32, 32, 32, 32, 82, 97, 47/ + data (st0022(iyy),iyy= 9,16) / 68,101, 99, 32, 97,120,101,115/ + data (st0022(iyy),iyy=17,24) / 58, 32, 32, 37,100, 47, 37,100/ + data (st0022(iyy),iyy=25,25) / 0/ + data (st0023(iyy),iyy= 1, 8) / 32, 32, 32, 32, 32, 32, 32, 32/ + data (st0023(iyy),iyy= 9,16) / 32, 32, 32, 32, 32, 32, 32, 32/ + data (st0023(iyy),iyy=17,24) / 32, 32, 68,105,109,101,110,115/ + data (st0023(iyy),iyy=25,32) /105,111,110,115, 58, 32, 32, 37/ + data (st0023(iyy),iyy=33,40) /100, 32,120, 32, 37,100, 10, 10/ + data (st0023(iyy),iyy=41,41) / 0/ + data (st0024(iyy),iyy= 1, 8) / 32, 32, 32, 32, 32, 32, 67,101/ + data (st0024(iyy),iyy= 9,16) /110,116,101,114, 32, 80,111,115/ + data (st0024(iyy),iyy=17,24) / 58, 32, 37, 51,115, 58, 32, 32/ + data (st0024(iyy),iyy=25,32) / 37, 45, 49, 50, 72, 32, 32, 32/ + data (st0024(iyy),iyy=33,40) / 32, 32, 32, 32, 32, 32, 32, 32/ + data (st0024(iyy),iyy=41,48) / 37, 51,115, 58, 32, 32, 37, 45/ + data (st0024(iyy),iyy=49,53) / 49, 50,104, 10, 0/ + data st0025 / 32, 82, 65, 0/ + data st0026 / 76,111,110, 0/ + data st0027 / 68,101, 99, 0/ + data st0028 / 76, 97,116, 0/ + data (st0029(iyy),iyy= 1, 8) / 32, 32, 32, 82,101,102,101,114/ + data (st0029(iyy),iyy= 9,16) /101,110, 99,101, 32, 80,111,115/ + data (st0029(iyy),iyy=17,24) / 58, 32, 37, 51,115, 58, 32, 32/ + data (st0029(iyy),iyy=25,32) / 37, 45, 49, 50, 72, 32, 32, 32/ + data (st0029(iyy),iyy=33,40) / 32, 32, 32, 32, 32, 32, 32, 32/ + data (st0029(iyy),iyy=41,48) / 37, 51,115, 58, 32, 32, 37, 45/ + data (st0029(iyy),iyy=49,53) / 49, 50,104, 10, 0/ + data st0030 / 32, 82, 65, 0/ + data st0031 / 76,111,110, 0/ + data st0032 / 68,101, 99, 0/ + data st0033 / 76, 97,116, 0/ + data (st0034(iyy),iyy= 1, 8) / 32, 82,101,102,101,114,101,110/ + data (st0034(iyy),iyy= 9,16) / 99,101, 32, 80,105,120,101,108/ + data (st0034(iyy),iyy=17,24) / 58, 32, 32, 32, 88, 58, 32, 32/ + data (st0034(iyy),iyy=25,32) / 37, 45, 57, 46, 52,102, 32, 32/ + data (st0034(iyy),iyy=33,40) / 32, 32, 32, 32, 32, 32, 32, 32/ + data (st0034(iyy),iyy=41,48) / 32, 32, 32, 32, 32, 32, 89, 58/ + data (st0034(iyy),iyy=49,56) / 32, 32, 37, 45, 57, 46, 52,102/ + data (st0034(iyy),iyy=57,58) / 10, 0/ + data (st0035(iyy),iyy= 1, 8) / 32, 32, 32, 32, 32, 80,108, 97/ + data (st0035(iyy),iyy= 9,16) /116,101, 32, 83, 99, 97,108,101/ + data (st0035(iyy),iyy=17,24) / 58, 32, 32, 37, 45, 56,102, 32/ + data (st0035(iyy),iyy=25,32) / 32, 32, 32, 32, 32, 32, 32, 32/ + data (st0035(iyy),iyy=33,40) / 32, 32, 32, 32, 32, 82,111,116/ + data (st0035(iyy),iyy=41,48) / 32, 65,110,103,108,101, 58, 32/ + data (st0035(iyy),iyy=49,55) / 32, 37, 45, 56,102, 10, 0/ + data (st0036(iyy),iyy= 1, 8) / 32, 32, 32, 32, 32, 32, 32, 32/ + data (st0036(iyy),iyy= 9,16) / 32, 69,113,117,105,110,111,120/ + data (st0036(iyy),iyy=17,24) / 58, 32, 32, 37,115, 37, 56,102/ + data (st0036(iyy),iyy=25,32) / 32, 32, 32, 32, 32, 32, 32, 32/ + data (st0036(iyy),iyy=33,40) / 32, 32, 32, 32, 32, 32, 32, 32/ + data (st0036(iyy),iyy=41,48) / 32, 69,112,111, 99,104, 58, 32/ + data (st0036(iyy),iyy=49,56) / 32, 37,115, 37, 46, 54,102, 10/ + data (st0036(iyy),iyy=57,57) / 0/ + data st0037 / 74, 0/ + data st0038 / 74, 0/ + data st0039 / 32, 0/ + data st0040 / 32, 0/ + data st0041 / 66, 0/ + data st0042 / 66, 0/ + data (st0043(iyy),iyy= 1, 8) / 32, 32, 32, 32, 32, 32, 32, 32/ + data (st0043(iyy),iyy= 9,16) / 32, 32, 32, 32, 32, 77, 74, 68/ + data (st0043(iyy),iyy=17,24) / 58, 32, 32, 37, 46, 54,102, 10/ + data (st0043(iyy),iyy=25,25) / 0/ + data st0044 /125, 10, 32, 10, 32, 10, 0/ + call smark (sp) + call salloc (buf, 1023 , 2) + call salloc (proj, 255 , 2) + call salloc (radecr, 255 , 2) + fd = stropn (memc(buf), 1023 , 3) + if (xerflg) goto 100 + img = memi(cp+3) + co = memi(img+4) + radecs = skstai (co, 8) + ctype = skstai (co, 7) + wtype = skstai (co, 9) + mw = memi(img+3) + if (.not.(mw .ne. 0)) goto 110 + ndim = mwstai (mw, 5 ) + call wcsgfm (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 (.not.(.not.fpequd (cd(1,1), 0.0d0))) goto 120 + xrot = ((atan ( cd(2,1) / cd(1,1)))*57.295779513082320877 + * d0) +120 continue + if (.not.(.not.fpequd (cd(2,2), 0.0d0))) goto 130 + yrot = ((atan (-cd(1,2) / cd(2,2)))*57.295779513082320877 + * d0) +130 continue + goto 111 +110 continue + ndim = 2 + xscale = 1.0 + yscale = 1.0 + xrot = 0.0 + yrot = 0.0 +111 continue + if (.not.(.false.)) goto 140 + call xprinf(st0001) + call xprinf(st0002) + call pargd(r(1)) + call pargd(r(2)) + call xprinf(st0003) + call pargd(w(1)) + call pargd(w(2)) + call xprinf(st0004) + call pargd(cd(1,1)) + call pargd(cd(1,2)) + call pargd(cd(2,1)) + call pargd(cd(2,2)) + call xprinf(st0005) + call pargd(xscale) + call pargd(yscale) + call xprinf(st0006) + call pargd(xrot) + call pargd(yrot) +140 continue + memr(img+10) = (xscale + yscale) / 2.0d0 + memr(img+9) = xrot + if (.not.(idxstr (radecs, memc(radecr), 255 , st0007) .le. 0)) + * goto 150 + call xstrcy(st0008, memc(radecr), 255 ) +150 continue + call strupr (memc(radecr)) + if (.not.(idxstr (wtype, memc(proj), 255 , st0009) .le. 0)) + * goto 160 + call xstrcy(st0010, memc(proj), 255 ) +160 continue + call strupr (memc(proj)) + call fprinf (fd, st0011) + call fprinf (fd, st0012) + call pargsr (memc(proj)) + sw0001=(ctype) + goto 170 +180 continue + call pargsr (st0013) + call pargsr (memc(radecr)) + goto 171 +190 continue + call pargsr (st0014) + call pargsr (st0015) + goto 171 +200 continue + call pargsr (st0016) + call pargsr (st0017) + goto 171 +210 continue + call pargsr (st0018) + call pargsr (st0019) + goto 171 +220 continue + call pargsr (st0020) + call pargsr (st0021) + goto 171 +170 continue + if (sw0001.lt.1.or.sw0001.gt.4) goto 220 + goto (180,190,200,210),sw0001 +171 continue + call fprinf (fd, st0022) + call pargi (skstai (co, 10)) + call pargi (skstai (co, 11)) + call fprinf (fd, st0023) + call pargi (meml(im+200 +1+8-1) ) + call pargi (meml(im+200 +2+8-1) ) + call fprinf (fd, st0024) + if (.not.(ctype .eq. 1)) goto 230 + call pargsr (st0025) + goto 231 +230 continue + call pargsr (st0026) +231 continue + call pargd (cval1) + if (.not.(ctype .eq. 1)) goto 240 + call pargsr (st0027) + goto 241 +240 continue + call pargsr (st0028) +241 continue + call pargd (cval2) + call fprinf (fd, st0029) + if (.not.(ctype .eq. 1)) goto 250 + call pargsr (st0030) + goto 251 +250 continue + call pargsr (st0031) +251 continue + call pargd (crval1) + if (.not.(ctype .eq. 1)) goto 260 + call pargsr (st0032) + goto 261 +260 continue + call pargsr (st0033) +261 continue + call pargd (crval2) + call fprinf (fd, st0034) + call pargd (crpix1) + call pargd (crpix2) + call fprinf (fd, st0035) + call pargr (memr(img+10) ) + call pargr (memr(img+9) ) + call fprinf (fd, st0036) + sw0002=(radecs) + goto 270 +280 continue + call pargsr (st0037) + call pargd (skstad(co,5)) + call pargsr (st0038) + call pargd (slepj(skstad(co,6))) + goto 271 +290 continue + if (.not.(memi(img+11) .eq. 1)) goto 300 + call pargsr (st0039) + call pargd (1.6d308) + call pargsr (st0040) + call pargd (1.6d308) + goto 301 +300 continue + call pargsr (st0041) + call pargd (skstad(co,5)) + call pargsr (st0042) + call pargd (slepb(skstad(co,6))) +301 continue + goto 271 +270 continue + if (sw0002.eq.3) goto 280 + if (sw0002.eq.4) goto 280 + goto 290 +271 continue + call fprinf (fd, st0043) + call pargd (skstad(co,6)) + call fprinf (fd, st0044) + call xfcloe(fd) + call wcspie (memc(buf)) + call sfree (sp) +100 return + end + subroutine imgseb (pixtab, size, x1, x2, y1, y2) + integer size + integer x1 + integer x2 + integer y1 + integer y2 + real pixtab(*) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer sp + integer buf + integer el + integer i + integer j + integer npix + real pix + real sum + real sum2 + real mean + real var + real stdev + real x + real y + integer*2 st0001(20) + integer*2 st0002(10) + integer*2 st0003(2) + integer*2 st0004(5) + integer*2 st0005(2) + integer*2 st0006(10) + integer*2 st0007(3) + integer*2 st0008(2) + integer*2 st0009(10) + integer*2 st0010(3) + integer*2 st0011(20) + integer*2 st0012(2) + save + integer iyy + data (st0001(iyy),iyy= 1, 8) /112,105,120,116, 97, 98, 32,123/ + data (st0001(iyy),iyy= 9,16) / 10,123, 10,116, 97, 98,108,101/ + data (st0001(iyy),iyy=17,20) / 32,123, 10, 0/ + data (st0002(iyy),iyy= 1, 8) / 32,123, 37, 49, 48, 46, 49,102/ + data (st0002(iyy),iyy= 9,10) /125, 0/ + data st0003 / 10, 0/ + data st0004 /125, 10,125, 10, 0/ + data st0005 /123, 0/ + data (st0006(iyy),iyy= 1, 8) / 32,123, 37, 49, 48, 46, 49,102/ + data (st0006(iyy),iyy= 9,10) /125, 0/ + data st0007 /125, 10, 0/ + data st0008 /123, 0/ + data (st0009(iyy),iyy= 1, 8) / 32,123, 37, 49, 48, 46, 49,102/ + data (st0009(iyy),iyy= 9,10) /125, 0/ + data st0010 /125, 10, 0/ + data (st0011(iyy),iyy= 1, 8) / 32,123, 32, 37, 49, 48, 46, 50/ + data (st0011(iyy),iyy= 9,16) /102, 32, 37, 49, 48, 46, 52,102/ + data (st0011(iyy),iyy=17,20) / 32,125, 10, 0/ + data st0012 /125, 0/ + call smark (sp) + call salloc (buf, (6*1023 ), 2) + call salloc (el, 255 , 2) + call xstrcy(st0001, memc(buf), (6*1023 )) + sum = 0.0 + sum2 = 0.0 + npix = size * size + i=size - 1 +110 if (.not.(i .ge. 0)) goto 112 + j=1 +120 if (.not.(j .le. size)) goto 122 + pix = pixtab((i * size) + j) + sum = sum + pix + sum2 = sum2 + (pix * pix) + call sprinf (memc(el), 255 , st0002) + call pargr (pix) + call xstrct(memc(el), memc(buf), (6*1023 )) +121 j=j+1 + goto 120 +122 continue + call xstrct(st0003, memc(buf), (6*1023 )) +111 i=i-1 + goto 110 +112 continue + call xstrct(st0004, memc(buf), (6*1023 )) + call xstrct(st0005, memc(buf), (6*1023 )) + x = x1 +130 if (.not.(x .le. x2)) goto 132 + call sprinf (memc(el), 255 , st0006) + call pargr (x) + call xstrct(memc(el), memc(buf), (6*1023 )) +131 x = x + 1. + goto 130 +132 continue + call xstrct(st0007, memc(buf), (6*1023 )) + call xstrct(st0008, memc(buf), (6*1023 )) + y = y2 +140 if (.not.(y .ge. y1)) goto 142 + call sprinf (memc(el), 255 , st0009) + call pargr (y) + call xstrct(memc(el), memc(buf), (6*1023 )) +141 y = y - 1. + goto 140 +142 continue + call xstrct(st0010, memc(buf), (6*1023 )) + mean = sum / real(npix) + var = (sum2 - sum * mean) / real(npix - 1) + if (.not.(var .le. 0)) goto 150 + stdev = 0.0 + goto 151 +150 continue + stdev = sqrt (var) +151 continue + call sprinf (memc(el), 255 , st0011) + call pargr (mean) + call pargr (stdev) + call xstrct(memc(el), memc(buf), (6*1023 )) + call xstrct(st0012, memc(buf), (6*1023 )) + call wcspie (memc(buf)) + call sfree (sp) +100 return + end + integer function imgams (im, mw) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer im + integer mw + integer ct + double precision r(7 ) + double precision w(7 ) + double precision cd(7 ,7 ) + double precision imgetd + integer mwsctn + integer*2 st0001(5) + integer*2 st0002(5) + integer*2 st0003(7) + integer*2 st0004(7) + integer*2 st0005(10) + integer*2 st0006(8) + integer*2 st0007(10) + save + integer iyy + data st0001 / 65, 84, 86, 49, 0/ + data st0002 / 65, 84, 86, 50, 0/ + data st0003 / 65, 84, 77, 49, 95, 49, 0/ + data st0004 / 65, 84, 77, 50, 95, 50, 0/ + data (st0005(iyy),iyy= 1, 8) / 97,109,112,108,105,102,105,101/ + data (st0005(iyy),iyy= 9,10) /114, 0/ + data st0006 /108,111,103,105, 99, 97,108, 0/ + data (st0007(iyy),iyy= 1, 8) / 97,109,112,108,105,102,105,101/ + data (st0007(iyy),iyy= 9,10) /114, 0/ + r(1) = 0.0d0 + r(2) = 0.0d0 + w(1) = imgetd (im, st0001) + w(2) = imgetd (im, st0002) + cd(1,1) = imgetd (im, st0003) + cd(1,2) = 0.0d0 + cd(2,1) = 0.0d0 + cd(2,2) = imgetd (im, st0004) + call mwnewm (mw, st0005, 2) + call mwswtd (mw, r, w, cd, 2) + ct = mwsctn (mw, st0006, st0007, 3) + call mwsdes (mw) + imgams = (ct) + goto 100 +100 return + end + integer function imgdes (im, mw) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer im + integer mw + integer ct + double precision r(7 ) + double precision w(7 ) + double precision cd(7 ,7 ) + double precision imgetd + integer mwsctn + integer*2 st0001(5) + integer*2 st0002(5) + integer*2 st0003(7) + integer*2 st0004(7) + integer*2 st0005(9) + integer*2 st0006(8) + integer*2 st0007(9) + save + integer iyy + data st0001 / 68, 84, 86, 49, 0/ + data st0002 / 68, 84, 86, 50, 0/ + data st0003 / 68, 84, 77, 49, 95, 49, 0/ + data st0004 / 68, 84, 77, 50, 95, 50, 0/ + data (st0005(iyy),iyy= 1, 8) /100,101,116,101, 99,116,111,114/ + data (st0005(iyy),iyy= 9, 9) / 0/ + data st0006 /108,111,103,105, 99, 97,108, 0/ + data (st0007(iyy),iyy= 1, 8) /100,101,116,101, 99,116,111,114/ + data (st0007(iyy),iyy= 9, 9) / 0/ + r(1) = 0.0d0 + r(2) = 0.0d0 + w(1) = imgetd (im, st0001) + w(2) = imgetd (im, st0002) + cd(1,1) = imgetd (im, st0003) + cd(1,2) = 0.0d0 + cd(2,1) = 0.0d0 + cd(2,2) = imgetd (im, st0004) + call mwnewm (mw, st0005, 2) + call mwswtd (mw, r, w, cd, 2) + ct = mwsctn (mw, st0006, st0007, 3) + call mwsdes (mw) + imgdes = (ct) + goto 100 +100 return + end + subroutine imgcos (cp, line, wcsnae, xunits, yunits) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer cp + integer line + integer*2 wcsnae(*) + integer*2 xunits(*) + integer*2 yunits(*) + integer img + integer co + integer wp + integer sp + integer proj + integer radecr + integer xstrcp + integer skstai + integer idxstr + integer sw0001,sw0002 + integer*2 st0001(5) + integer*2 st0002(5) + integer*2 st0003(5) + integer*2 st0004(5) + integer*2 st0005(5) + integer*2 st0006(5) + integer*2 st0007(5) + integer*2 st0008(5) + integer*2 st0009(9) + integer*2 st0010(5) + integer*2 st0011(5) + integer*2 st0012(9) + integer*2 st0013(5) + integer*2 st0014(5) + integer*2 st0015(14) + integer*2 st0016(5) + integer*2 st0017(5) + integer*2 st0018(5) + integer*2 st0019(5) + integer*2 st0020(2) + integer*2 st0021(2) + integer*2 st0022(9) + integer*2 st0023(3) + integer*2 st0024(4) + integer*2 st0025(4) + integer*2 st0026(5) + integer*2 st0027(5) + integer*2 st0028(30) + integer*2 st0029(4) + integer*2 st0030(2) + integer*2 st0031(3) + integer*2 st0032(114) + integer*2 st0033(7) + integer*2 st0034(4) + integer*2 st0035(4) + integer*2 st0036(5) + integer*2 st0037(6) + integer*2 st0038(9) + save + integer iyy + data st0001 / 32, 32, 82, 65, 0/ + data st0002 / 32, 68,101, 99, 0/ + data st0003 / 69, 76,111,110, 0/ + data st0004 / 69, 76, 97,116, 0/ + data st0005 / 71, 76,111,110, 0/ + data st0006 / 71, 76, 97,116, 0/ + data st0007 / 83, 76,111,110, 0/ + data st0008 / 83, 76, 97,116, 0/ + data (st0009(iyy),iyy= 1, 8) /101, 99,108,105,112,116,105, 99/ + data (st0009(iyy),iyy= 9, 9) / 0/ + data st0010 / 69, 76,111,110, 0/ + data st0011 / 69, 76, 97,116, 0/ + data (st0012(iyy),iyy= 1, 8) /103, 97,108, 97, 99,116,105, 99/ + data (st0012(iyy),iyy= 9, 9) / 0/ + data st0013 / 71, 76,111,110, 0/ + data st0014 / 71, 76, 97,116, 0/ + data (st0015(iyy),iyy= 1, 8) /115,117,112,101,114,103, 97,108/ + data (st0015(iyy),iyy= 9,14) / 97, 99,116,105, 99, 0/ + data st0016 / 83, 76,111,110, 0/ + data st0017 / 83, 76, 97,116, 0/ + data st0018 / 32, 32, 82, 65, 0/ + data st0019 / 32, 68,101, 99, 0/ + data st0020 / 88, 0/ + data st0021 / 89, 0/ + data (st0022(iyy),iyy= 1, 8) / 37,115, 45, 37,115, 45, 37,115/ + data (st0022(iyy),iyy= 9, 9) / 0/ + data st0023 / 69, 81, 0/ + data st0024 / 69, 67, 76, 0/ + data st0025 / 71, 65, 76, 0/ + data st0026 / 83, 71, 65, 76, 0/ + data st0027 / 85, 78, 75, 78, 0/ + data (st0028(iyy),iyy= 1, 8) /124,102,107, 52,124,102,107, 52/ + data (st0028(iyy),iyy= 9,16) / 45,110,111, 45,101,124,102,107/ + data (st0028(iyy),iyy=17,24) / 53,124,105, 99,114,115,124,103/ + data (st0028(iyy),iyy=25,30) / 97,112,112,116,124, 0/ + data st0029 / 70, 75, 53, 0/ + data st0030 / 45, 0/ + data st0031 / 45, 45, 0/ + data (st0032(iyy),iyy= 1, 8) /124,108,105,110,124, 97,122,112/ + data (st0032(iyy),iyy= 9,16) /124,116, 97,110,124,115,105,110/ + data (st0032(iyy),iyy=17,24) /124,115,116,103,124, 97,114, 99/ + data (st0032(iyy),iyy=25,32) /124,122,112,110,124,122,101, 97/ + data (st0032(iyy),iyy=33,40) /124, 97,105,114,124, 99,121,112/ + data (st0032(iyy),iyy=41,48) /124, 99, 97,114,124,109,101,114/ + data (st0032(iyy),iyy=49,56) /124, 99,101, 97,124, 99,111,112/ + data (st0032(iyy),iyy=57,64) /124, 99,111,100,124, 99,111,101/ + data (st0032(iyy),iyy=65,72) /124, 99,111,111,124, 98,111,110/ + data (st0032(iyy),iyy=73,80) /124,112, 99,111,124,103,108,115/ + data (st0032(iyy),iyy=81,88) /124,112, 97,114,124, 97,105,116/ + data (st0032(iyy),iyy=89,96) /124,109,111,108,124, 99,115, 99/ + data (st0032(iyy),iyy=97,104) /124,113,115, 99,124,116,115, 99/ + data (st0032(iyy),iyy=105,112) /124,116,110,120,124,122,112,120/ + data (st0032(iyy),iyy=113,114) /124, 0/ + data st0033 /108,105,110,101, 97,114, 0/ + data st0034 /102,107, 52, 0/ + data st0035 /102,107, 53, 0/ + data st0036 /105, 99,114,115, 0/ + data st0037 /103, 97,112,112,116, 0/ + data (st0038(iyy),iyy= 1, 8) /102,107, 52, 45,110,111, 45,101/ + data (st0038(iyy),iyy= 9, 9) / 0/ + img = memi(cp+3) + co = memi(img+4) + wp = memi(img ) + if (.not.(memi(memi(wp+3) +line-1) .eq. 4 )) goto 110 + sw0001=(skstai(co,7)) + goto 120 +130 continue + call xstrcy(st0001, xunits, 32 ) + call xstrcy(st0002, yunits, 32 ) + goto 121 +140 continue + call xstrcy(st0003, xunits, 32 ) + call xstrcy(st0004, yunits, 32 ) + goto 121 +150 continue + call xstrcy(st0005, xunits, 32 ) + call xstrcy(st0006, yunits, 32 ) + goto 121 +160 continue + call xstrcy(st0007, xunits, 32 ) + call xstrcy(st0008, yunits, 32 ) + goto 121 +120 continue + if (sw0001.lt.1.or.sw0001.gt.4) goto 121 + goto (130,140,150,160),sw0001 +121 continue + goto 111 +110 continue + if (.not.(memi(memi(wp+3) +line-1) .eq. 5 )) goto 170 + call xstrcy(memc(memi(wp+4) +(32 *(line-1))), wcsnae, 32 ) + call strlwr (wcsnae) + if (.not.(xstrcp(wcsnae,st0009) .eq. 0)) goto 180 + call xstrcy(st0010, xunits, 32 ) + call xstrcy(st0011, yunits, 32 ) + goto 181 +180 continue + if (.not.(xstrcp(wcsnae,st0012) .eq. 0)) goto 190 + call xstrcy(st0013, xunits, 32 ) + call xstrcy(st0014, yunits, 32 ) + goto 191 +190 continue + if (.not.(xstrcp(wcsnae,st0015) .eq. 0)) goto 200 + call xstrcy(st0016, xunits, 32 ) + call xstrcy(st0017, yunits, 32 ) + goto 201 +200 continue + call xstrcy(st0018, xunits, 32 ) + call xstrcy(st0019, yunits, 32 ) +201 continue +191 continue +181 continue + goto 171 +170 continue + call xstrcy(st0020, xunits, 32 ) + call xstrcy(st0021, yunits, 32 ) +171 continue +111 continue + if (.not.(memi(memi(wp+3) +line-1) .ne. 4 )) goto 210 + call xstrcy(memc(memi(wp+4) +(32 *(line-1))), wcsnae, 32 ) + goto 211 +210 continue + call smark (sp) + call salloc (radecr, 255 , 2) + call salloc (proj, 255 , 2) + call sprinf (wcsnae, 32 , st0022) + sw0002=(skstai(co,7)) + goto 220 +230 continue + call pargsr (st0023) + goto 221 +240 continue + call pargsr (st0024) + goto 221 +250 continue + call pargsr (st0025) + goto 221 +260 continue + call pargsr (st0026) + goto 221 +270 continue + call pargsr (st0027) + goto 221 +220 continue + if (sw0002.lt.1.or.sw0002.gt.4) goto 270 + goto (230,240,250,260),sw0002 +221 continue + if (.not.(skstai(co,7) .eq. 1)) goto 280 + if (.not.(idxstr(skstai(co,8), memc(radecr), 255 , st0028 + * ) .le. 0)) goto 290 + call xstrcy(st0029, memc(radecr), 255 ) +290 continue + call strupr (memc(radecr)) + call pargsr (memc(radecr)) + goto 281 +280 continue + if (.not.(skstai(co,7) .eq. 4)) goto 300 + call pargsr (st0030) + goto 301 +300 continue + call pargsr (st0031) +301 continue +281 continue + if (.not.(idxstr(skstai(co,9), memc(proj), 255 , st0032) .le + * . 0)) goto 310 + call xstrcy(st0033, memc(proj), 255 ) +310 continue + call strupr (memc(proj)) + call pargsr (memc(proj)) + call sfree (sp) +211 continue + if (.not.(xstrcp(wcsnae, st0034) .eq. 0 .or. xstrcp(wcsnae, + * st0035) .eq. 0 .or. xstrcp(wcsnae, st0036) .eq. 0 .or. xstrcp( + * wcsnae, st0037) .eq. 0 .or. xstrcp(wcsnae, st0038) .eq. 0)) + * goto 320 + call strupr (wcsnae) + goto 321 +320 continue + if (.not.((wcsnae(1).ge.97.and.wcsnae(1).le.122))) goto 330 + wcsnae(1) = (wcsnae(1)+65-97) +330 continue +321 continue +100 return + end + subroutine imgcot (cp, line, xval, yval, xc, yc) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer cp + integer line + double precision xval + double precision yval + integer*2 xc(*) + integer*2 yc(*) + integer img + integer co + integer wp + integer*2 xfmt(32 +1) + integer*2 yfmt(32 +1) + integer skstai + logical streq + integer*2 st0001(7) + integer*2 st0002(7) + integer*2 st0003(9) + integer*2 st0004(9) + integer*2 st0005(14) + integer*2 st0006(3) + integer*2 st0007(5) + integer*2 st0008(5) + integer*2 st0009(7) + integer*2 st0010(7) + integer*2 st0011(5) + integer*2 st0012(5) + integer*2 st0013(3) + integer*2 st0014(7) + integer*2 st0015(7) + save + integer iyy + data st0001 / 37, 49, 48, 46, 50,102, 0/ + data st0002 / 37, 49, 48, 46, 50,102, 0/ + data (st0003(iyy),iyy= 1, 8) /101, 99,108,105,112,116,105, 99/ + data (st0003(iyy),iyy= 9, 9) / 0/ + data (st0004(iyy),iyy= 1, 8) /103, 97,108, 97, 99,116,105, 99/ + data (st0004(iyy),iyy= 9, 9) / 0/ + data (st0005(iyy),iyy= 1, 8) /115,117,112,101,114,103, 97,108/ + data (st0005(iyy),iyy= 9,14) / 97, 99,116,105, 99, 0/ + data st0006 / 37,104, 0/ + data st0007 / 37, 46, 50, 72, 0/ + data st0008 / 37, 46, 49,104, 0/ + data st0009 / 37, 49, 48, 46, 50,102, 0/ + data st0010 / 37, 49, 48, 46, 50,102, 0/ + data st0011 / 37, 46, 50, 72, 0/ + data st0012 / 37, 46, 49,104, 0/ + data st0013 / 37,104, 0/ + data st0014 / 37, 49, 48, 46, 50,102, 0/ + data st0015 / 37, 49, 48, 46, 50,102, 0/ + img = memi(cp+3) + co = memi(img+4) + wp = memi(img ) + if (.not.(memi(memi(wp+5) +line-1) .eq. 1 )) goto 110 + if (.not.(memi(img+3) .eq. 0)) goto 120 + call xstrcy(st0001, xfmt, 32 ) + call xstrcy(st0002, yfmt, 32 ) + goto 121 +120 continue + if (.not.(memi(memi(wp+3) +line-1) .eq. 4 .or. memi(memi( + * wp+3) +line-1) .eq. 5 )) goto 130 + if (.not.(streq(memc(memi(wp+4) +(32 *(line-1))), + * st0003) .or. streq(memc(memi(wp+4) +(32 *(line-1))), + * st0004) .or. streq(memc(memi(wp+4) +(32 *(line-1))), + * st0005))) goto 140 + call xstrcy(st0006, xfmt, 32 ) + goto 141 +140 continue + call xstrcy(st0007, xfmt, 32 ) +141 continue + call xstrcy(st0008, yfmt, 32 ) + goto 131 +130 continue + call xstrcy(st0009, xfmt, 32 ) + call xstrcy(st0010, yfmt, 32 ) +131 continue +121 continue + goto 111 +110 continue + if (.not.(memi(memi(wp+5) +line-1) .eq. 2 )) goto 150 + if (.not.(skstai(co, 7) .eq. 1)) goto 160 + call xstrcy(st0011, xfmt, 32 ) + goto 161 +160 continue + call xstrcy(st0012, xfmt, 32 ) +161 continue + call xstrcy(st0013, yfmt, 32 ) + goto 151 +150 continue + call xstrcy(st0014, xfmt, 32 ) + call xstrcy(st0015, yfmt, 32 ) +151 continue +111 continue + call sprinf (xc, 32 , xfmt) + if (.not.(memi(memi(wp+5) +line-1) .ne. 4 )) goto 170 + call pargd (xval) + goto 171 +170 continue + call pargd (((xval)/57.295779513082320877)) +171 continue + call sprinf (yc, 32 , yfmt) + if (.not.(memi(memi(wp+5) +line-1) .ne. 4 )) goto 180 + call pargd (yval) + goto 181 +180 continue + call pargd (((yval)/57.295779513082320877)) +181 continue +100 return + end + subroutine imgged (img, x, y, system, wcsnae, wx, wy) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer img + double precision x + double precision y + integer system + double precision wx + double precision wy + integer*2 wcsnae(*) + double precision ox + double precision oy + real epoch + integer im + integer co + integer nco + integer*2 buf(1023 +1) + integer stat + real imgetr + integer imaccf + integer skstai + integer skdecr + logical streq + integer sw0001 + logical xerflg + common /xercom/ xerflg + integer*2 st0001(9) + integer*2 st0002(6) + integer*2 st0003(6) + integer*2 st0004(6) + integer*2 st0005(8) + save + integer iyy + data (st0001(iyy),iyy= 1, 8) /101, 99,108,105,112,116,105, 99/ + data (st0001(iyy),iyy= 9, 9) / 0/ + data st0002 /103, 97,112,112,116, 0/ + data st0003 / 69, 80, 79, 67, 72, 0/ + data st0004 / 69, 80, 79, 67, 72, 0/ + data st0005 / 37,115, 32, 37, 46, 49,102, 0/ + im = memi(img+1) + co = memi(img+4) + wx = x + wy = y + sw0001=(system) + goto 110 +120 continue + wx = x + wy = y + goto 111 +130 continue + if (.not.(memi(img+6) .ne. 0)) goto 140 + call mwc2td (memi(img+6) , x, y, wx, wy) +140 continue + goto 111 +150 continue + if (.not.(memi(img+5) .ne. 0)) goto 160 + call mwc2td (memi(img+5) , x, y, wx, wy) +160 continue + goto 111 +170 continue + if (.not.(memi(img+7) .ne. 0)) goto 180 + call mwc2td (memi(img+7) , x, y, wx, wy) +180 continue + goto 111 +190 continue + goto 111 +200 continue + if (.not.(memi(img+8) .ne. 0)) goto 210 + call mwc2td (memi(img+8) , x, y, wx, wy) +210 continue + goto 111 +220 continue + if (.not.(streq (wcsnae, st0001) .or. streq (wcsnae, st0002) + * )) goto 230 + if (.not.(imaccf (im, st0003) .eq. 1)) goto 240 + epoch = imgetr (im, st0004) + if (xerflg) goto 100 + if (.not.(epoch .eq. 0.0 .or. ((epoch).eq.1.6e38))) + * goto 250 + epoch = 1950.0 +250 continue + goto 241 +240 continue + epoch = 1950.0 +241 continue + call sprinf (buf, 1023 , st0005) + call pargsr (wcsnae) + call pargr (epoch) + goto 231 +230 continue + call xstrcy(wcsnae, buf, 1023 ) +231 continue + stat = skdecr (buf, nco, co) + if (.not.(stat .ne. -1)) goto 260 + if (.not.(memi(img+5) .ne. 0)) goto 270 + call mwc2td (memi(img+5) , x, y, ox, oy) +270 continue + call sklltn (co, nco, ((ox)/57.295779513082320877), ((oy) + * /57.295779513082320877), 1.6d308, 1.6d308, 0.0d0, 0.0d0, + * wx, wy) + if (.not.(skstai(co,11) .lt. skstai(co,10))) goto 280 + wx = ((wy)*57.295779513082320877) + wy = ((wx)*57.295779513082320877) + goto 281 +280 continue + wx = ((wx)*57.295779513082320877) + wy = ((wy)*57.295779513082320877) +281 continue +260 continue + goto 111 +290 continue + goto 111 +300 continue + wx = x + wy = y + goto 111 +110 continue + if (sw0001.lt.1.or.sw0001.gt.9) goto 300 + goto (120,300,130,150,220,170,190,200,290),sw0001 +111 continue +100 return + end +c sprinf sprintf +c temple template +c skstad sk_statd +c wcspie wcspix_message +c imgser img_send_header +c radecs radecsys +c stropn stropen +c skstai sk_stati +c skdecr sk_decwstr +c imgcae img_cache +c mwstai mw_stati +c getlie getline +c skdecm sk_decim +c imgses img_send_compass +c imgseo img_send_wcsinfo +c ximalt xim_alert +c wcsnae wcsname +c bpmpix bpm_pix +c mwc2td mw_c2trand +c imgune img_uncache +c imgwcn img_wcstran +c mwswtd mw_swtermd +c sklltn sk_lltran +c mwsctn mw_sctran +c imunmp imunmap +c imgwct img_wcslist +c keywfr keyw_filter +c imgged img_get_coord +c fprinf fprintf +c imgint img_init +c imofnu imofnlu +c dspmmp ds_pmmap +c imggea img_get_data +c imgseb img_send_pixtab +c imgcos img_coord_labels +c imgcot img_coord_fmt +c imgobo img_objinfo +c putlie putline +c imgdes img_det_wcs +c hdrsie hdr_size +c radecr radecstr +c imgams img_amp_wcs +c pargsr pargstr +c mwcloe mw_close +c mwnewm mw_newsystem +c wcsgfm wcs_gfterm +c fpequd fp_equald +c mwsdes mw_sdefwcs diff --git a/vendor/x11iraf/ximtool/clients.old/wcspix/wcimage.x b/vendor/x11iraf/ximtool/clients.old/wcspix/wcimage.x new file mode 100644 index 00000000..a21571a3 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/wcspix/wcimage.x @@ -0,0 +1,1268 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <math.h> +include <imio.h> +include <imhdr.h> +include <ctype.h> +include <mwset.h> +include "../lib/skywcs/skywcs.h" +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_MW(img) = NULL + IMG_CO(img) = NULL + IMG_CTW(img) = NULL + IMG_CTP(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 +int stat +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 + +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 xim_alert (alert, "", "") + return + } + + IMG_CO(img) = NULL + IMG_CTW(img) = NULL + IMG_CTP(img) = NULL + iferr { + stat = sk_decim (IMG_IM(img), "world", IMG_MW(img), IMG_CO(img)) + if (stat == ERR || 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. + im = IMG_IM(img) + 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 xim_alert (alert, "", "") + IMG_LINEAR(img) = YES + } + + # See if we can find a bad pixel mask. + 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_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 <objid> } { region <regionid> } +# { pixval <pixel_value> [<units>] } +# { bpm <bpm_pixel_value> } +# { coord <wcsname> <x> <y> [<xunits> <yunits>] } +# { coord <wcsname> <x> <y> [<xunits> <yunits>] } +# : +# } + + +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, pixval +real rx, ry +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 pargd (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 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) + call strcat (" line ", msg, SZ_LINE) + + # If we have a MWCS pointer list the sky projections. + if (mw != NULL) + 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 +double pixval #o central pixel value +int bpm_pix #o bad pixel mask value + +pointer img, wp, im, bpm, pix +int nl, nc, ix, iy +int size, x1, x2, y1, y2 + +pointer imgs2r(), imgs2i() + +begin + if (IMG_DEBUG) call printf ("img_get_data: \n") + + 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) + + # Sanity check on the cursor image position. + if (x < 0.0 || y < 0.0 || x > nc || y > nl) + 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 = max (size/2+1, ix) ; iy = max (size/2+1, iy) + ix = min (ix, (nc-(size/2)-1)) ; iy = min (iy, (nl-(size/2)-1)) + + # 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 + + # Get the image pixels + x1 = max (1, x1) + x2 = min (nc, x2) + y1 = max (1, y1) + y2 = min (nl, y2) + pix = imgs2r (im, int(x1), int(x2), int(y1), int(y2)) + + if (bpm != NULL && WP_BPM(wp) == YES) + bpm_pix = Memi[imgs2i (bpm, ix, ix, iy, iy)] + else + bpm_pix = 0 + + # Compute the image pixel associated with the requested coords. + pixval = Memr[pix + ((size/2)*size) + (size/2)] * 1.0d0 + + # Send the pixel table. + if (WP_PTABSZ(wp) > 1) + call img_send_pixtab (Memr[pix], WP_PTABSZ(wp), x1, x2, y1, y2) +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 +double cx, cy, cx1, cy1, dx, dy, x1, y1 +double cosa, sina, angle +int i, j, comp_x, comp_y +long axis[IM_MAXDIM], lv[IM_MAXDIM], pv1[IM_MAXDIM], pv2[IM_MAXDIM] + +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 (IMG_ROT(img) > 0.0) + angle = -IMG_ROT(img) + else + angle = IMG_ROT(img) + 360.0 + cosa = cos (DEGTORAD(angle)) + sina = sin (DEGTORAD(angle)) + + # 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 + + # 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 + + } 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 %s\0") + call pargi (C_OBJID(cp)) + call pargr (IMG_ROT(img)) + call pargi (comp_x) + call pargi (comp_y) + if (IMG_MW(img) != NULL) + call pargstr ("E N") + else + call pargstr ("X Y") + + call wcspix_message (Memc[buf]) + call sfree (sp) +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 +# { <mean> <stdev> } # 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) + + # 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 +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_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) + case SYS_AMP: + if (IMG_CTA(img) != NULL) + call mw_c2trand (IMG_CTA(img), x, y, wx, wy) + case SYS_CCD: + ; # TBD + 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 (streq (wcsname, "ecliptic") || streq (wcsname, "gappt")) { + if (imaccf (im, "EPOCH") == YES) { + epoch = imgetr (im, "EPOCH") + if (epoch == 0.0 || IS_INDEFR(epoch)) + epoch = 1950.0 + } else + epoch = 1950.0 + + call sprintf (buf, SZ_LINE, "%s %.1f") + call pargstr (wcsname) + call pargr (epoch) + } else + call strcpy (wcsname, buf, SZ_LINE) + + 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) + } + } + case SYS_OTHER: + ; # TBD + + default: # default coords + wx = x + wy = y + } +end diff --git a/vendor/x11iraf/ximtool/clients.old/wcspix/wcmef.f b/vendor/x11iraf/ximtool/clients.old/wcspix/wcmef.f new file mode 100644 index 00000000..d98ff3e6 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/wcspix/wcmef.f @@ -0,0 +1,30 @@ + subroutine mefint () + save +100 return + end + subroutine mefcae () + save +100 return + end + subroutine mefune () + save +100 return + end + subroutine mefwcn () + save +100 return + end + subroutine mefwct () + save +100 return + end + subroutine mefobo () + save +100 return + end +c mefcae mef_cache +c mefune mef_uncache +c mefwcn mef_wcstran +c mefwct mef_wcslist +c mefint mef_init +c mefobo mef_objinfo diff --git a/vendor/x11iraf/ximtool/clients.old/wcspix/wcmef.x b/vendor/x11iraf/ximtool/clients.old/wcspix/wcmef.x new file mode 100644 index 00000000..050e5596 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/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.old/wcspix/wcmspec.f b/vendor/x11iraf/ximtool/clients.old/wcspix/wcmspec.f new file mode 100644 index 00000000..c2924bd1 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/wcspix/wcmspec.f @@ -0,0 +1,30 @@ + subroutine mspint () + save +100 return + end + subroutine mspcae () + save +100 return + end + subroutine mspune () + save +100 return + end + subroutine mspwcn () + save +100 return + end + subroutine mspwct () + save +100 return + end + subroutine mspobo () + save +100 return + end +c mspwct msp_wcslist +c mspint msp_init +c mspobo msp_objinfo +c mspcae msp_cache +c mspune msp_uncache +c mspwcn msp_wcstran diff --git a/vendor/x11iraf/ximtool/clients.old/wcspix/wcmspec.x b/vendor/x11iraf/ximtool/clients.old/wcspix/wcmspec.x new file mode 100644 index 00000000..64198d69 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/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.old/wcspix/wcspix.h b/vendor/x11iraf/ximtool/clients.old/wcspix/wcspix.h new file mode 100644 index 00000000..e0657154 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/wcspix/wcspix.h @@ -0,0 +1,111 @@ +# 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|logical|physical|world|sky\ + |amplifier|ccd|detector|other|" +define SYS_NONE 1 # no coords requested +define SYS_LOGICAL 2 # logical coords +define SYS_PHYSICAL 3 # physical coords +define SYS_WORLD 4 # world coords +define SYS_SKY 5 # sky coords +define SYS_AMP 6 # amplifier coords +define SYS_CCD 7 # CCD coords +define SYS_DETECTOR 8 # detector coords +define SYS_OTHER 9 # ??? 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 YES # 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.old/wcspix/wcunknown.f b/vendor/x11iraf/ximtool/clients.old/wcspix/wcunknown.f new file mode 100644 index 00000000..0061fbcd --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/wcspix/wcunknown.f @@ -0,0 +1,229 @@ + subroutine unkint (cp, wp) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer cp + integer wp + logical xerpop + logical xerflg + common /xercom/ xerflg + save + if (.not.(memi(cp+3) .eq. 0)) goto 110 + call xerpsh + call xcallc(memi(cp+3) , 1, 10 ) + if (.not.xerpop()) goto 120 + goto 100 +120 continue +110 continue + memi(memi(cp+3) ) = wp +100 return + end + subroutine unkcae (cp, objid, regid, ref) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer cp + integer objid + integer regid + integer*2 ref(*) + save + memi(cp) = objid + memi(cp+1) = regid + memi(cp+4) = memi(cp+4) + 1 + call xstrcy(ref, memc((((cp+6)-1)*2+1)) , 128) +100 return + end + subroutine unkune (cp, id) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer cp + integer id + integer*2 st0001(1) + save + data st0001 / 0/ + memi(cp) = 0 + memi(cp+4) = 0 + call xstrcy(st0001, memc((((cp+6)-1)*2+1)) , 255 ) + call xmfree(memi(cp+3) , 10 ) + memi(cp+3) = 0 +100 return + end + subroutine unkwcn (cp, id, x, y) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer cp + integer id + real x + real y + integer wp + integer i + integer*2 buf(1023 +1) + integer*2 msg(1023 +1) + integer*2 st0001(37) + integer*2 st0002(27) + integer*2 st0003(37) + integer*2 st0004(5) + save + integer iyy + data (st0001(iyy),iyy= 1, 8) /119, 99,115,116,114, 97,110, 32/ + data (st0001(iyy),iyy= 9,16) /123, 32,111, 98,106,101, 99,116/ + data (st0001(iyy),iyy=17,24) / 32, 37,100, 32,125, 32,123, 32/ + data (st0001(iyy),iyy=25,32) /114,101,103,105,111,110, 32, 37/ + data (st0001(iyy),iyy=33,37) /100, 32,125, 32, 0/ + data (st0002(iyy),iyy= 1, 8) /123, 32,112,105,120,118, 97,108/ + data (st0002(iyy),iyy= 9,16) / 32, 48, 46, 48, 32,125, 32,123/ + data (st0002(iyy),iyy=17,24) / 32, 98,112,109, 32, 48, 32,125/ + data (st0002(iyy),iyy=25,27) / 32, 10, 0/ + data (st0003(iyy),iyy= 1, 8) /123, 99,111,111,114,100, 32,123/ + data (st0003(iyy),iyy= 9,16) / 37, 57,115,125, 32,123, 37, 49/ + data (st0003(iyy),iyy=17,24) / 50,103,125, 32,123, 37, 49, 50/ + data (st0003(iyy),iyy=25,32) /103,125, 32,123, 88,125, 32,123/ + data (st0003(iyy),iyy=33,37) / 89,125,125, 10, 0/ + data st0004 / 85, 78, 75, 78, 0/ + wp = memi(memi(cp+3) ) + call aclrc (msg, 1023 ) + call sprinf (msg, 1023 , st0001) + call pargi (memi(cp) ) + call pargi (memi(cp+1) ) + call xstrct(st0002, msg, 1023 ) + i=1 +110 if (.not.(i .le. 4 )) goto 112 + call sprinf (buf, 1023 , st0003) + call pargsr (st0004) + call pargr (x) + call pargr (y) + call xstrct(buf, msg, 1023 ) +111 i=i+1 + goto 110 +112 continue + call wcspie (msg) +100 return + end + subroutine unkwct (cp, id) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer cp + integer id + save +100 return + end + subroutine unkgea (cp, id, x, y, pixval) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer cp + integer id + real x + real y + real pixval + integer wp + integer pix + integer size + integer x1 + integer x2 + integer y1 + integer y2 + save + wp = memi(memi(cp+3) ) + size = memi(wp+1) + 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 + if (.not.(size .gt. 1)) goto 110 + call xcallc(pix, size * size, 6) + call imgseb (memr(pix), size, x1, x2, y1, y2) + call xmfree(pix, 6) +110 continue +100 return + end + subroutine unkobo (cp, id, temple) + logical Memb(1) + integer*2 Memc(1) + integer*2 Mems(1) + integer Memi(1) + integer*4 Meml(1) + real Memr(1) + double precision Memd(1) + complex Memx(1) + equivalence (Memb, Memc, Mems, Memi, Meml, Memr, Memd, Memx) + common /Mem/ Memd + integer cp + integer id + integer*2 temple(*) + integer sp + integer buf + integer*2 st0001(25) + save + integer iyy + data (st0001(iyy),iyy= 1, 8) / 99,111,109,112, 97,115,115, 32/ + data (st0001(iyy),iyy= 9,16) / 37,100, 32, 48, 46, 48, 32, 45/ + data (st0001(iyy),iyy=17,24) / 49, 32, 49, 32, 88, 32, 89, 0/ + data (st0001(iyy),iyy=25,25) / 0/ + call smark (sp) + call salloc (buf, 1023 , 2) + call aclrc (memc(buf), 1023 ) + call sprinf (memc(buf), 1023 , st0001) + call pargi (memi(cp) ) + call wcspie (memc(buf)) + call sfree (sp) +100 return + end +c sprinf sprintf +c temple template +c wcspie wcspix_message +c unkwct unk_wcslist +c unkint unk_init +c unkobo unk_objinfo +c unkcae unk_cache +c imgseb img_send_pixtab +c unkune unk_uncache +c unkwcn unk_wcstran +c pargsr pargstr +c unkgea unk_getdata diff --git a/vendor/x11iraf/ximtool/clients.old/wcspix/wcunknown.x b/vendor/x11iraf/ximtool/clients.old/wcspix/wcunknown.x new file mode 100644 index 00000000..9a1afe1b --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/wcspix/wcunknown.x @@ -0,0 +1,185 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <ctype.h> +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 <objid> } { region <regionid> } +# { pixval <pixelvalue> [<units>] } +# { coord <wcsname> <x> <y> [<xunits> <yunits>] } +# { coord <wcsname> <x> <y> [<xunits> <yunits>] } +# } + + +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 X Y\0") + call pargi (C_OBJID(cp)) + call wcspix_message (Memc[buf]) + + call sfree (sp) +end diff --git a/vendor/x11iraf/ximtool/clients.old/x_ism.f b/vendor/x11iraf/ximtool/clients.old/x_ism.f new file mode 100644 index 00000000..218b5d0b --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/x_ism.f @@ -0,0 +1,145 @@ + integer function sysruk (task, cmd, rukarf, rukint) + integer rukarf + integer rukint + integer*2 task(*) + integer*2 cmd(*) + integer i + integer ntasks + integer lmarg + integer rmarg + integer maxch + integer ncol + integer rukean + integer envgei + integer envscn + logical streq + logical xerpop + logical xerflg + common /xercom/ xerflg + integer iyy + integer dp(2) + integer*2 dict(7) + integer*2 st0001(9) + integer*2 st0002(6) + integer*2 st0003(3) + integer*2 st0004(6) + integer*2 st0005(6) + integer*2 st0006(4) + integer*2 st0007(6) + integer*2 st0008(2) + integer*2 st0009(29) + integer*2 st0010(25) + save + data dict /119, 99,115,112,105,120, 0/ + data (st0001(iyy),iyy= 1, 8) /116,116,121,110, 99,111,108,115/ + data (st0001(iyy),iyy= 9, 9) / 0/ + data st0002 / 99,104,100,105,114, 0/ + data st0003 / 99,100, 0/ + data st0004 /104,111,109,101, 36, 0/ + data st0005 / 72, 79, 77, 69, 36, 0/ + data st0006 /115,101,116, 0/ + data st0007 /114,101,115,101,116, 0/ + data st0008 / 9, 0/ + data (st0009(iyy),iyy= 1, 8) /105,110,118, 97,108,105,100, 32/ + data (st0009(iyy),iyy= 9,16) /115,101,116, 32,115,116, 97,116/ + data (st0009(iyy),iyy=17,24) /101,109,101,110,116, 58, 32, 39/ + data (st0009(iyy),iyy=25,29) / 37,115, 39, 10, 0/ + data (st0010(iyy),iyy= 1, 8) /105,110,118, 97,108,105,100, 32/ + data (st0010(iyy),iyy= 9,16) / 83, 69, 84, 32,105,110, 32, 73/ + data (st0010(iyy),iyy=17,24) / 82, 65, 70, 32, 77, 97,105,110/ + data (st0010(iyy),iyy=25,25) / 0/ + data (dp(iyy),iyy= 1, 2) / 1, 0/ + data lmarg /5/, maxch /0/, ncol /0/, rukean /3/ + data ntasks /0/ + if (.not.(ntasks .eq. 0)) goto 110 + i=1 +120 if (.not.(dp(i) .ne. 0)) goto 122 +121 i=i+1 + goto 120 +122 continue + ntasks = i - 1 +110 continue + if (.not.(task(1) .eq. 63)) goto 130 + call xerpsh + rmarg = envgei (st0001) + if (.not.xerpop()) goto 140 + rmarg = 80 +140 continue + call strtbl (4, dict, dp, ntasks, lmarg, rmarg, maxch, ncol) + sysruk = (0) + goto 100 +130 continue + if (.not.(streq(task,st0002) .or. streq(task,st0003))) goto 150 + call xerpsh + if (.not.(cmd(rukarf) .eq. 0)) goto 170 + call xerpsh + call xfchdr(st0004) + if (.not.xerpop()) goto 180 + call xfchdr(st0005) +180 continue + goto 171 +170 continue + call xfchdr(cmd(rukarf)) +171 continue +162 if (.not.xerpop()) goto 160 + if (.not.(rukint .eq. 1)) goto 190 + call erract (rukean) + if (xerflg) goto 100 + goto 191 +190 continue +191 continue +160 continue + sysruk = (0) + goto 100 +150 continue + if (.not.(streq(task,st0006) .or. streq(task,st0007))) goto 200 + call xerpsh + if (.not.(cmd(rukarf) .eq. 0)) goto 220 + call envlit (4, st0008, 1) + call xffluh(4) + goto 221 +220 continue + if (.not.(envscn (cmd) .le. 0)) goto 230 + if (.not.(rukint .eq. 1)) goto 240 + call eprinf (st0009) + call pargsr (cmd) + goto 241 +240 continue + goto 91 +241 continue +230 continue +221 continue +212 if (.not.xerpop()) goto 210 + if (.not.(rukint .eq. 1)) goto 250 + call erract (rukean) + if (xerflg) goto 100 + goto 251 +250 continue +91 call syspac (0, st0010) +251 continue +210 continue + sysruk = (0) + goto 100 +200 continue +151 continue +131 continue + if (.not.(streq (task, dict(dp(1))))) goto 260 + call twcspx + sysruk = (0) + goto 100 +260 continue + sysruk = (-1) + goto 100 +100 return + end +c rukint ruk_interact +c sysruk sys_runtask +c envscn envscan +c twcspx t_wcspix +c envgei envgeti +c syspac sys_panic +c eprinf eprintf +c rukarf ruk_argoff +c rukean ruk_eawarn +c pargsr pargstr +c envlit envlist diff --git a/vendor/x11iraf/ximtool/clients.old/x_ism.x b/vendor/x11iraf/ximtool/clients.old/x_ism.x new file mode 100644 index 00000000..8f401873 --- /dev/null +++ b/vendor/x11iraf/ximtool/clients.old/x_ism.x @@ -0,0 +1 @@ +task wcspix = t_wcspix |