From fa080de7afc95aa1c19a6e6fc0e0708ced2eadc4 Mon Sep 17 00:00:00 2001
From: Joseph Hunkeler <jhunkeler@gmail.com>
Date: Wed, 8 Jul 2015 20:46:52 -0400
Subject: Initial commit

---
 sys/mwcs/mwscale.x | 49 +++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 49 insertions(+)
 create mode 100644 sys/mwcs/mwscale.x

(limited to 'sys/mwcs/mwscale.x')

diff --git a/sys/mwcs/mwscale.x b/sys/mwcs/mwscale.x
new file mode 100644
index 00000000..2ae7167a
--- /dev/null
+++ b/sys/mwcs/mwscale.x
@@ -0,0 +1,49 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	"mwcs.h"
+
+# MW_SCALE -- Front end to mw_translate, used to perform a simple rescaling
+# of the logical system.
+
+procedure mw_scale (mw, scale, axbits)
+
+pointer	mw			#I pointer to MWCS descriptor
+real	scale[ARB]		#I scale factor for each axis in axbits
+int	axbits			#I bitflags defining axes
+
+pointer	sp, ltm, ltv_1, ltv_2
+int	axis[MAX_DIM], naxes, pdim, nelem, axmap, i, j
+
+begin
+	# Convert axis bitflags to axis list.
+	call mw_gaxlist (mw, axbits, axis, naxes)
+	if (naxes <= 0)
+	    return
+
+	pdim = MI_NDIM(mw)
+	nelem = pdim * pdim
+	axmap = MI_USEAXMAP(mw)
+	MI_USEAXMAP(mw) = NO
+
+	call smark (sp)
+	call salloc (ltm, nelem, TY_DOUBLE)
+	call salloc (ltv_1, pdim, TY_DOUBLE)
+	call salloc (ltv_2, pdim, TY_DOUBLE)
+
+	# Initialize the translation matrix and vectors.
+	call mw_mkidmd (Memd[ltm], pdim)
+	call aclrd (Memd[ltv_1], pdim)
+	call aclrd (Memd[ltv_2], pdim)
+
+	# Enter the axis scale factors.
+	do i = 1, naxes {
+	    j = axis[i] - 1
+	    Memd[ltm+j*pdim+j] = scale[i]
+	}
+
+	# Perform the translation.
+	call mw_translated (mw, Memd[ltv_1], Memd[ltm], Memd[ltv_2], pdim)
+
+	MI_USEAXMAP(mw) = axmap
+	call sfree (sp)
+end
-- 
cgit