aboutsummaryrefslogtreecommitdiff
path: root/vendor/x11iraf/ximtool/clients.old/wcspix
diff options
context:
space:
mode:
authorJoseph Hunkeler <jhunkeler@gmail.com>2015-07-08 20:46:52 -0400
committerJoseph Hunkeler <jhunkeler@gmail.com>2015-07-08 20:46:52 -0400
commitfa080de7afc95aa1c19a6e6fc0e0708ced2eadc4 (patch)
treebdda434976bc09c864f2e4fa6f16ba1952b1e555 /vendor/x11iraf/ximtool/clients.old/wcspix
downloadiraf-linux-fa080de7afc95aa1c19a6e6fc0e0708ced2eadc4.tar.gz
Initial commit
Diffstat (limited to 'vendor/x11iraf/ximtool/clients.old/wcspix')
-rw-r--r--vendor/x11iraf/ximtool/clients.old/wcspix/README0
-rw-r--r--vendor/x11iraf/ximtool/clients.old/wcspix/class.com6
-rw-r--r--vendor/x11iraf/ximtool/clients.old/wcspix/mkpkg15
-rw-r--r--vendor/x11iraf/ximtool/clients.old/wcspix/t_wcspix.f1124
-rw-r--r--vendor/x11iraf/ximtool/clients.old/wcspix/t_wcspix.x769
-rw-r--r--vendor/x11iraf/ximtool/clients.old/wcspix/wcimage.f1975
-rw-r--r--vendor/x11iraf/ximtool/clients.old/wcspix/wcimage.x1268
-rw-r--r--vendor/x11iraf/ximtool/clients.old/wcspix/wcmef.f30
-rw-r--r--vendor/x11iraf/ximtool/clients.old/wcspix/wcmef.x50
-rw-r--r--vendor/x11iraf/ximtool/clients.old/wcspix/wcmspec.f30
-rw-r--r--vendor/x11iraf/ximtool/clients.old/wcspix/wcmspec.x50
-rw-r--r--vendor/x11iraf/ximtool/clients.old/wcspix/wcspix.h111
-rw-r--r--vendor/x11iraf/ximtool/clients.old/wcspix/wcunknown.f229
-rw-r--r--vendor/x11iraf/ximtool/clients.old/wcspix/wcunknown.x185
14 files changed, 5842 insertions, 0 deletions
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
generated by cgit (git 2.34.1) at 2025-09-22 03:41:31 -0400