Repatch (from linux) of OSX IRAF

1 files changed, 266 insertions, 0 deletions

diff --git a/pkg/utilities/nttools/ttranspose/ttrflip.x b/pkg/utilities/nttools/ttranspose/ttrflip.x
new file mode 100644
index 00000000..3c008f68
--- /dev/null
+++ b/pkg/utilities/nttools/ttranspose/ttrflip.x
@@ -0,0 +1,266 @@
+# This file contains ttr_trans and ttr_flip.  The former copies data
+# from one table to another and transposes rows and columns, while the
+# latter copies data without transposing.  Either routine may also flip
+# rows and/or columns, i.e. first input row to last output row, or first
+# input column to last input column.
+#
+# Phil Hodge, 30-Nov-1994  Subroutines created.
+
+# ttr_trans -- copy data from input to output
+# This routine transposes a table.
+
+procedure ttr_trans (itp, otp, icp, ocp,
+		irows, icols, orows, ocols, op, dtype, nelem)
+
+pointer itp		# i: pointer to input table struct
+pointer otp		# i: pointer to output table struct
+pointer icp[icols]	# i: array of pointers to input column descriptors
+pointer ocp[irows]	# i: array of pointers to output column descriptors
+int	irows		# i: number of rows in input table
+int	icols		# i: number of columns in input table
+int	orows		# i: number of rows in output table
+int	ocols		# i: number of columns in output table
+int	op[2]		# i: mapping of (columns,rows) from input to output
+int	dtype		# i: data type of column
+int	nelem		# i: length of array stored at each row,column
+#--
+pointer sp
+pointer buf		# scratch for copying array entries
+int	clen		# length of char string (= -dtype)
+int	i, j		# loop indices for input table
+int	oi, oj		# loop indices for output table
+int	oj_start	# starting value for oj
+int	oi_incr, oj_incr	# increments in oi, oj
+
+# buffers for copying one element:
+pointer cbuf
+double	dbuf
+real	rbuf
+int	ibuf
+short	sbuf
+bool	bbuf
+
+int	nret		# number of array elements actually read and written
+int	tbagtd(), tbagtr(), tbagti(), tbagts(), tbagtb(), tbagtt()
+errchk	tbegtd, tbegtr, tbegti, tbegts, tbegtb, tbegtt,
+	tbeptd, tbeptr, tbepti, tbepts, tbeptb, tbeptt,
+	tbagtd, tbagtr, tbagti, tbagts, tbagtb, tbagtt,
+	tbaptd, tbaptr, tbapti, tbapts, tbaptb, tbaptt
+
+begin
+	call smark (sp)
+
+	# Assign values for the beginning and increment for the loops
+	# on oi and oj.
+	if (op[1] > 0) {
+	    oi = 1
+	    oi_incr = 1
+	} else {
+	    oi = ocols			# = irows
+	    oi_incr = -1
+	}
+	if (op[2] > 0) {
+	    oj_start = 1
+	    oj_incr = 1
+	} else {
+	    oj_start = orows		# = icols
+	    oj_incr = -1
+	}
+
+	if (dtype < 0)
+	    clen = -dtype
+
+	if (nelem == 1) {
+
+	    if (dtype == TY_REAL) {
+		do j = 1, irows {
+		    oj = oj_start	# oj, not oi, because we're transposing
+		    do i = 1, icols {
+			call tbegtr (itp, icp[i], j, rbuf)
+			call tbeptr (otp, ocp[oi], oj, rbuf)
+			oj = oj + oj_incr
+		    }
+		    oi = oi + oi_incr
+		}
+	    } else if (dtype == TY_DOUBLE) {
+		do j = 1, irows {
+		    oj = oj_start
+		    do i = 1, icols {
+			call tbegtd (itp, icp[i], j, dbuf)
+			call tbeptd (otp, ocp[oi], oj, dbuf)
+			oj = oj + oj_incr
+		    }
+		    oi = oi + oi_incr
+		}
+	    } else if (dtype == TY_INT) {
+		do j = 1, irows {
+		    oj = oj_start
+		    do i = 1, icols {
+			call tbegti (itp, icp[i], j, ibuf)
+			call tbepti (otp, ocp[oi], oj, ibuf)
+			oj = oj + oj_incr
+		    }
+		    oi = oi + oi_incr
+		}
+	    } else if (dtype == TY_SHORT) {
+		do j = 1, irows {
+		    oj = oj_start
+		    do i = 1, icols {
+			call tbegts (itp, icp[i], j, sbuf)
+			call tbepts (otp, ocp[oi], oj, sbuf)
+			oj = oj + oj_incr
+		    }
+		    oi = oi + oi_incr
+		}
+	    } else if (dtype == TY_BOOL) {
+		do j = 1, irows {
+		    oj = oj_start
+		    do i = 1, icols {
+			call tbegtb (itp, icp[i], j, bbuf)
+			call tbeptb (otp, ocp[oi], oj, bbuf)
+			oj = oj + oj_incr
+		    }
+		    oi = oi + oi_incr
+		}
+	    } else if (dtype < 0) {
+		call salloc (cbuf, SZ_LINE, TY_CHAR)
+		do j = 1, irows {
+		    oj = oj_start
+		    do i = 1, icols {
+			call tbegtt (itp, icp[i], j, Memc[cbuf], SZ_LINE)
+			call tbeptt (otp, ocp[oi], oj, Memc[cbuf])
+			oj = oj + oj_incr
+		    }
+		    oi = oi + oi_incr
+		}
+	    } else {
+		call error (1, "invalid data type")
+	    }
+
+	} else {			# each entry is an array
+
+	    if (dtype > 0)
+		call salloc (buf, nelem, dtype)
+
+	    if (dtype == TY_REAL) {
+		do j = 1, irows {
+		    oj = oj_start
+		    do i = 1, icols {
+			nret = tbagtr (itp, icp[i], j, Memr[buf], 1, nelem)
+			call tbaptr (otp, ocp[oi], oj, Memr[buf], 1, nret)
+			oj = oj + oj_incr
+		    }
+		    oi = oi + oi_incr
+		}
+	    } else if (dtype == TY_DOUBLE) {
+		do j = 1, irows {
+		    oj = oj_start
+		    do i = 1, icols {
+			nret = tbagtd (itp, icp[i], j, Memd[buf], 1, nelem)
+			call tbaptd (otp, ocp[oi], oj, Memd[buf], 1, nret)
+			oj = oj + oj_incr
+		    }
+		    oi = oi + oi_incr
+		}
+	    } else if (dtype == TY_INT) {
+		do j = 1, irows {
+		    oj = oj_start
+		    do i = 1, icols {
+			nret = tbagti (itp, icp[i], j, Memi[buf], 1, nelem)
+			call tbapti (otp, ocp[oi], oj, Memi[buf], 1, nret)
+			oj = oj + oj_incr
+		    }
+		    oi = oi + oi_incr
+		}
+	    } else if (dtype == TY_SHORT) {
+		do j = 1, irows {
+		    oj = oj_start
+		    do i = 1, icols {
+			nret = tbagts (itp, icp[i], j, Mems[buf], 1, nelem)
+			call tbapts (otp, ocp[oi], oj, Mems[buf], 1, nret)
+			oj = oj + oj_incr
+		    }
+		    oi = oi + oi_incr
+		}
+	    } else if (dtype == TY_BOOL) {
+		do j = 1, irows {
+		    oj = oj_start
+		    do i = 1, icols {
+			nret = tbagtb (itp, icp[i], j, Memb[buf], 1, nelem)
+			call tbaptb (otp, ocp[oi], oj, Memb[buf], 1, nret)
+			oj = oj + oj_incr
+		    }
+		    oi = oi + oi_incr
+		}
+	    } else if (dtype < 0) {
+		call salloc (buf, (clen+1) * nelem, TY_CHAR)	# add 1 for EOS
+		do j = 1, irows {
+		    oj = oj_start
+		    do i = 1, icols {
+			nret = tbagtt (itp, icp[i], j, Memc[buf], clen,
+					1, nelem)
+			call tbaptt (otp, ocp[oi], oj, Memc[buf], clen, 1, nret)
+			oj = oj + oj_incr
+		    }
+		    oi = oi + oi_incr
+		}
+	    } else {
+		call error (1, "invalid data type")
+	    }
+	}
+
+	call sfree (sp)
+end
+
+# ttr_flip -- copy data from input to output
+# This routine copies a table without transposing.
+# irows and icols are the numbers of rows and columns in both the
+# input and output tables.
+# Note that if we are reversing the order of the columns (horizontal flip),
+# the last column of the input table was defined first, so the flip in
+# column order is taken care of by the relative order of the elements of
+# the arrays icp and ocp.
+
+procedure ttr_flip (itp, otp, icp, ocp, irows, icols, op)
+
+pointer itp		# i: pointer to input table struct
+pointer otp		# i: pointer to output table struct
+pointer icp[icols]	# i: array of pointers to input column descriptors
+pointer ocp[ARB]	# i: array of pointers to output column descriptors
+int	irows		# i: number of rows in input table
+int	icols		# i: number of columns in input table
+int	op[2]		# i: mapping of (columns,rows) from input to output
+#--
+int	j		# loop index for input row number
+int	oj, oj_incr	# loop index and increment for output row number
+errchk tbrcpy, tbrcsc
+
+begin
+	# Assign values for the beginning and increment for the loop
+	# on output row number.
+	if (op[2] > 0) {
+	    oj = 1
+	    oj_incr = 1
+	} else {
+	    oj = irows
+	    oj_incr = -1
+	}
+
+	# Copy the data from input to output.
+	if (op[1] > 0) {
+
+	    # Retain column order.
+	    do j = 1, irows {
+		call tbrcpy (itp, otp, j, oj)
+		oj = oj + oj_incr
+	    }
+
+	} else {					# op[1] < 0
+
+	    # Reverse column order.
+	    do j = 1, irows {
+		call tbrcsc (itp, otp, icp, ocp, j, oj, icols)
+		oj = oj + oj_incr
+	    }
+	}
+end