#!/bin/sh
#
#	This is a shell archive, meaning:
#
#	1. Remove everything above the #!/bin/sh line.
#	2. Save the resulting text in a file.
#	3. Execute the file with /bin/sh (not csh) to create:
#		icvtf.c
#
# This archive created: Wed Oct 25 11:57:51 EDT 1989
#
f=icvtf.c
if [ -s $f ]; then echo "shar: $f already exists - not extracted"
else sed -n 's/^XX//p' >$f <<'*-*-END-of-icvtf.c-*-*'
XX#ifdef vax
XX #
XX #		   General Image Processing System
XX #			   Peter G. Ford
XX #		      Center for Space Research
XX #	Copyright 1984 Massachusetts Institute of Technology
XX #
XX #	Module:		icvtf.c		Creation Date:	04/28/84
XX #	Version:	2.1		Update:		11/14/86
XX #	Function:	Convert an IBM binary array to a VAX binary array.
XX #			Called from Fortran or C routines.
XX #	Syntax:		ierr = icvti(iibm, nitem, iarr);
XX #			ierr = icvtf(fibm, nitem, farr);
XX #			ierr = icvtd(dibm, nitem, darr);
XX #			ierr:	number of conversion errors (see note 3)
XX #			iibm:	input array of 4-byte IBM integers
XX #			iarr:	output array of 4-byte VAX integers
XX #			fibm:	input array of 4-byte IBM floats
XX #			farr:	output array of 4-byte VAX F-format floats
XX #			dibm:	input array of 8-byte IBM doubles (REAL*8)
XX #			darr:	output array of 8-byte VAX doubles (D-format)
XX #			nitem:	number of items to convert
XX #
XX #	Notes:	[1]	It is assumed that the IBM input fields have
XX #			NOT already been byte-swapped.
XX #		[2]	Unnormalized IBM floats are interpreted correctly.
XX #		[3]	While there are no specific bit patterns that represent
XX #			illegal IBM floating point fields, the IBM exponent
XX #			range is larger than the VAX. Fields that would
XX #			cause overflow or underflow when converting are
XX #			set to the hexadecimal values described below. The
XX #			value returned by icvtf or icvtd tells the calling
XX #			program the number of such fix-ups that were made.
XX #			icvti always returns a zero value.
XX #			Routine		Condition	Output Value
XX #			icvtf		underflow 	0x00000100
XX #			icvtf		overflow	0xffffffff
XX #			icvtd		underflow	0x0000010000000000
XX #			icvtd		overflow	0xffffffffffffffff
XX #
XX #	Entry Points:
XX	.globl	_icvti		# Convert IBM INTEGER*4 to Fortran integer*4
XX	.globl	_icvti_		# Convert IBM INTEGER*4 to C long int
XX	.globl	_icvtf		# Convert IBM REAL*4 to Fortran real*4
XX	.globl	_icvtf_		# Convert IBM REAL*4 to C float
XX	.globl	_icvtd		# Convert IBM REAL*8 to Fortran real*8
XX	.globl	_icvtd_		# Convert IBM REAL*8 to C double (long float)
XX
XX	.data
XX	.asciz	"@(#)icvtf.c	GIPS 2.1 (MIT/CSR) 11/14/86"
XX	.text
XX	.align	1
XX_icvti_:.word	0xe00		# define register mask
XX	movl	*8(ap),r10	# load integer count
XX	jbr	1f		# branch to common code
XX	.align	1
XX_icvti:	.word	0xe00		# define register mask
XX	movl	8(ap),r10	# load integer count
XX1:	movl	12(ap),r9	# point to VAX longs (output)
XX	movl	4(ap),r11	# point to IBM integer*4's (input)
XX	movl	12(ap),r9	# point to VAX longs (output)
XX2:	sobgeq	r10,3f		# loop over integer count
XX	clrl	r0		# clear return code
XX	ret			# done
XX3:	movb	(r11)+,r0	# load the first byte
XX	ashl	$8,r0,r0	# shift left
XX	movb	(r11)+,r0	# load the second byte
XX	ashl	$8,r0,r0	# shift left
XX	movb	(r11)+,r0	# load the third byte
XX	ashl	$8,r0,r0	# shift left
XX	movb	(r11)+,r0	# load the fourth byte
XX	movl	r0,(r9)+	# store the answer
XX	jbr	2b		# loop again
XX
XX	.align	1
XX_icvtf_:.word	0xfc0		# define register mask
XX	movl	*8(ap),r10	# load float count
XX	jbr	1f		# branch to common code
XX	.align	1
XX_icvtf:	.word	0xfc0		# define register mask
XX	movl	8(ap),r10	# load float count
XX1:	movl	4(ap),r11	# point to IBM floats (input)
XX	movl	12(ap),r9	# point to VAX floats (output)
XX	clrl	r0		# clear return register
XX2:	sobgeq	r10,3f		# loop over floats count
XX	ret			# done
XX3:	movzbl	(r11)+,r8	# load the IBM sign and exponent
XX	bicl3	$0x80,r8,r7	# extract the IBM exponent
XX	ashl	$2,r7,r7	# convert exponent to binary
XX	subl2	$127,r7		# re-bias to VAX specs
XX	movb	(r11)+,r6	# load first mantissa byte
XX	ashl	$8,r6,r6	# shift left
XX	movb	(r11)+,r6	# load second mantissa byte
XX	ashl	$8,r6,r6	# shift left
XX	movb	(r11)+,r6	# load third mantissa byte
XX	ashl	$8,r6,r6	# shift mantissa into sign bit
XX	jeql	5f		# if zero, so is the float!
XX4:	decl	r7		# decrement the exponent
XX	jleq	6f		# branch if underflow
XX	rotl	$1,r6,r6	# rotate the mantissa
XX	jlbc	r6,4b		# ... until leading bit drops off
XX	cmpl	$255,r7		# test again
XX	jlss	7f		# branch if overflow
XX	bicl2	$1,r6		# clear the hidden bit
XX	bisl2	r7,r6		# insert the binary exponent
XX	rotl	$7,r6,r6	# put mantissa in proper place
XX	jbc	$7,r8,5f	# branch unless float is negative
XX	bisl2	$0x8000,r6	# negate our float
XX5:	movl	r6,(r9)+	# store the answer
XX	jbr	2b		# loop over specified floats
XX6:	movl	$0x00000100,r6	# insert the smallest VAX float
XX	jbr	8f		# continue
XX7:	movl	$0xffffffff,r6	# insert the largest VAX float
XX8:	incl	r0		# increment error count
XX	jbr	5b		# continue
XX
XX	.align	1
XX_icvtd_:.word	0xfe0		# define register mask
XX	movl	*8(ap),r10	# load doubles count
XX	jbr	1f		# branch to common code
XX	.align	1
XX_icvtd:	.word	0xfe0		# define register mask
XX	movl	8(ap),r10	# load doubles count
XX1:	movl	4(ap),r11	# point to IBM doubles (input)
XX	movl	12(ap),r9	# point to VAX doubles (output)
XX	clrl	r0		# clear return register
XX2:	sobgeq	r10,3f		# loop over doubles count
XX	ret			# done
XX3:	movzbl	(r11)+,r8	# load the IBM sign and exponent
XX	bicl3	$0x80,r8,r7	# extract the IBM exponent
XX	ashl	$2,r7,r7	# convert exponent to binary
XX	subl2	$127,r7		# re-bias to VAX specs
XX	movb	(r11)+,r5	# load first mantissa byte
XX	ashl	$8,r5,r5	# shift left
XX	movb	(r11)+,r5	# load second mantissa byte
XX	ashl	$8,r5,r5	# shift left
XX	movb	(r11)+,r5	# load third mantissa byte
XX	movb	(r11)+,r6	# load fourth mantissa byte
XX	ashl	$8,r6,r6	# shift left
XX	movb	(r11)+,r6	# load fifth mantissa byte
XX	ashl	$8,r6,r6	# shift left
XX	movb	(r11)+,r6	# load sixth mantissa byte
XX	ashl	$8,r6,r6	# shift left
XX	movb	(r11)+,r6	# load seventh and last mantissa byte
XX	ashl	$8,r5,r5	# shift upper mantissa into sign bit
XX	jneq	4f		# branch if non-zero
XX	tstl	r6		# test the lower mantissa
XX	jeql	6f		# if zero, so is the double!
XX4:	rotl	$1,r5,r5	# rotate msb to lsb
XX	decl	r7		# decrement the exponent
XX	jleq	7f		# branch if underflow
XX	jlbs	r5,5f		# get out of loop if set
XX	rotl	$1,r6,r6	# rotate lower mantissa
XX	jlbc	r6,4b		# branch if bit not set
XX	bisl2	$0x100,r5	# insert the bit in the upper mantissa
XX	bicl2	$1,r6		# clear it from the lower mantissa
XX	jbr	4b		# continue the shift loop
XX5:	cmpl	$255,r7		# test the exponent
XX	jlss	8f		# branch if overflow
XX	bicl2	$1,r5		# clear the hidden bit
XX	bisl2	r7,r5		# insert the binary exponent
XX	rotl	$7,r5,r5	# put mantissa in proper place
XX	rotl	$16,r6,r6	# rotate lower mantissa too
XX	jbc	$7,r8,6f	# branch unless float is negative
XX	bisl2	$0x8000,r5	# negate our double
XX6:	movq	r5,(r9)+	# store the answer
XX	jbr	2b		# loop over specified doubles
XX7:	movl	$0x00000100,r5	# insert the smallest VAX double
XX	clrl	r6		# clear lower mantissa
XX	jbr	9f		# continue
XX8:	movl	$0xffffffff,r5	# insert the largest VAX double
XX	movl	r5,r6		# copy to lower mantissa
XX9:	incl	r0		# increment error count
XX	jbr	6b		# continue
XX
XX#else
XX
XX#ifndef lint
XXstatic char *sccsid = "@(#)icvtf.c	GIPS 2.1 (MIT/CSR) 11/14/86";
XX#endif
XX
XXstatic	int	errors		= -1;		/* init flag & error count */
XXstatic	double	table[256]	= { 0.0 };	/* powers of 2 */
XX
XXstatic
XXinit()
XX{
XX	register i = 127;
XX	register double *d1 = &table[128];
XX	register double *d2;
XX
XX	for (*(d2 = d1) = 1.0; --i > 0; d1++)
XX		*--d2 = 1.0/(d1[1] = 2 * *d1);
XX	d1[1] = *d1;
XX	d2[-1] = *d2;
XX}
XX
XXstatic double
XXdconv(buf, sw)
XX
XX	register unsigned char	*buf;
XX	register		sw;
XX{
XX	register unsigned char	*b	= buf;
XX	register unsigned long	fract	= 0;
XX	register		exp	= 4;
XX	register		shft;
XX	double			f;
XX	static	short		shift[]	= {-1,3,2,2,1,1,1,1,0,0,0,0,0,0,0,0};
XX
XX	while (--exp >= 0)
XX		fract = (fract << 8) | *b++;
XX	shft = shift[(fract >> 20) & 0xf];
XX	if (shft < 0) {
XX		if (fract) errors++;
XX		return 0;
XX	}
XX	exp = ((int)((fract >> 24) & 0177)-64)*4+128-shft;
XX	fract = (fract << shft) & 0xffffff;
XX	if (exp <= 1)
XX		if (exp == 1)
XX			fract >>= 1;
XX		else {
XX			exp = 1;
XX			fract = 0x800000;
XX			errors++;
XX		}
XX	else if (exp >= 255)
XX		if (exp == 255)
XX			fract <<= 1;
XX		else {
XX			exp = 255;
XX			fract = 0x7fffff;
XX			errors++;
XX		}
XX	f = fract * table[104];
XX	if (sw) {
XX		for (fract = 0, sw = 4; --sw >= 0; )
XX			fract = (fract << 8) | *b++ ;
XX		if (fract & 0x80000000) {
XX			fract &= ~0x80000000;
XX			f += table[104-1+shft];
XX		}
XX		f += fract * table[104-32+shft];
XX	}
XX	return f * ((*buf & 0x80) ? -table[exp] : table[exp]);
XX}
XX
XXicvtf(fibm, nitem, farr)
XX
XX	register char	*fibm;
XX	register int	nitem;
XX	register float	*farr;
XX{
XX	if (errors < 0) init();
XX	for (errors = 0; --nitem >= 0; fibm += 4)
XX		*farr++ = (float) dconv((unsigned char *)fibm, 0);
XX	return errors;
XX}
XX
XXicvtd(dibm, nitem, darr)
XX
XX	register char	*dibm;
XX	register int	nitem;
XX	register double	*darr;
XX{
XX	if (errors < 0) init();
XX	for (errors = 0; --nitem >= 0; dibm += 8)
XX		*darr++ = dconv((unsigned char *)dibm, 1);
XX	return errors;
XX}
XX
XXicvti(iibm, nitem, iarr)
XX
XX	register char	*iibm;
XX	register int	nitem;
XX	register int	*iarr;
XX{
XX	register i;
XX	register n;
XX
XX	for ( ; --nitem >= 0; *iarr++ = n)
XX		for (n = 0, i = 4; --i >= 0; )
XX			n = (n << 8) | (*iibm++ & 0377);
XX	return 0;
XX}
XX
XXicvtf_(fibm, pts, farr)
XX
XX	char	*fibm;
XX	int	*pts;
XX	float  	*farr;
XX{
XX	return icvtf(fibm, *pts, farr);
XX}
XX
XXicvtd_(dibm, pts, darr)
XX
XX	char	*dibm;
XX	int	*pts;
XX	double	*darr;
XX{
XX	return icvtd(dibm, *pts, darr);
XX}
XX
XXicvti_(iibm, pts, iarr)
XX
XX	char	*iibm;
XX	int	*pts;
XX	int	*iarr;
XX{
XX	return icvti(iibm, *pts, iarr);
XX}
XX#endif
*-*-END-of-icvtf.c-*-*
echo -n "Copied: " ; ls -l $f
if [ ` wc -c <$f ` !=  8973 ]
then echo "shar: warning possible error in $f"
fi;fi
#-----------------------------------------------------------------------