C+
C NAME:
C	ice_write
C PURPOSE:
C	Writes an integer array to a compressed file
C CATEGORY:
C	Bits and bytes
C CALLING SEQUENCE:
	function ice_write(iAct0, cFile, ibytes, packfraction, nOrig, Orig, nPack, Pack, cExtra)
C INPUTS:
C	ibytes		integer		effective # bytes in Orig
C					e.g. if the original data were integer*2
C					set ibytes=2 (ibytes is used only to
C					calculate the compression ratio)
C	packfraction	real		threshold for compression (fraction of
C					original size). The compressed file is
C					written only if the compression is
C					better than packfraction.
C	nOrig		integer		# elements in Orig
C	Orig(nOrig)	integer		array to be compressed
C	cFile		character*(*)	file name
C
C	nPack		integer		# elements in Pack
C	Pack		integer		scratch array (needed to store the compressed data)
C	cExtra		character*(*)	optional string to be appended to compressed file.
C OUTPUTS:
C	ice_write	integer		0: failure (an error message is displayed)
C					1: success
C CALLS:
C	bOpenFile, iFreeLun, ice_analyze, ice_pack, itrim, Int2Str, Flt2Str
C	Str2Str, Say, iSetFileSpec, iPutFileSpec, iGetFileSpec, ArrI4Copy
C	ArrI4Zero
C INCLUDE:
	include		'openfile.h'
	include		'filparts.h'
C SEE ALSO:
C	ice_read
C PROCEDURE:
C >	If the compression ratio is larger than one then no file is written
C	(irrespective of the packfraction input value).
C >	See href=ice_pack= for information on the compression algorithm.
C	The output file is organized in 512 byte (128 longword) records:
C	The first record contains the compression parameters:
C		Longword 1 and 2: 8 byte string containing version information.
C		Longword 3: length of original array (# elements)
C		Longword 4: ibit; # bits in compressed data
C		Longword 5: kmax
C		Longword 6: kshift
C		Longword 7: klenbit
C		Longword 8: ksign
C		Longword 9: nextra; # characters in trailer
C		Longwords 10...9+kmax-kshift: permutation table
C		The record is padded with zeros to 128 longwords.
C	Next follows the compressed data array (ibit bits), written in blocks
C	of 512 bytes; the last data record is again padded with zeros to 128
C	longwords.
C	At the end follows the trailer (nextrac bytes), again written in
C	blocks of 512 bytes with the last record padded with zeroes to 128
C	longwords.
C MODIFICATION HISTORY:
C	AUG-2000, Paul Hick (UCSD/CASS)
C		Version 1
C	AUG-2003, Paul Hick (UCSD/CASS; pphick@ucsd.edu)
C		Version 2. No changes to ice_write and ice_read, but
C		the program href=rice= now also can deal with integer*4
C		data. This information is stored in a trailer.
C		The new version number is needed to reconstruct the original
C		trailer info. 
C-
	    integer	iAct0
	    character	cFile*(*)
	    integer	ibytes
	    real	packfraction
	    integer	nOrig
	    integer	Orig(nOrig)
	    integer	nPack
	    integer	Pack(nPack)
	    character	cExtra*(*)

	parameter	(nbit = 32)
	parameter	(nbit1 = nbit-1)
	parameter	(nByte = 512)
	parameter	(nRecl = nByte/4)		! Write 512 bytes records

	integer		kperm(0:nbit1)

	integer		nStore (nRecl)
	character	cStore*(nByte)
	equivalence	(nStore, cStore)

	integer		iVers(2)
	character	cVers*8			/'ice 0002'/
	equivalence	(iVers, cVers)

	character	cSay*9			/'ice_write'/
	character	cStr*120
	integer		Str2Str
	integer		Flt2Str

	logical		bOpenFile

	ice_write = 0

	ibit = ice_analyze(kmax, kshift, klenbit, ksign, kperm, nOrig, Orig)

	fraction = float(ibit)/(nOrig*8*max(1,min(ibytes,nbit/8)))

	if (fraction .lt. min(1.,packfraction)) then
	    ibit = ice_pack(kmax, kshift, klenbit, ksign, kperm, nOrig, Orig, nPack, Pack, iPack)

	    if (ibit .ne. 0) then
		L = len(cStr)

		I = 0
		I = I+Str2Str('to f ='		, cStr(I+1:))+1
		I = I+Flt2Str(fraction, 3	, cStr(I+1:))
		I = I+Str2Str('; max ='		, cStr(I+1:))+1
		I = I+Int2Str(kmax		, cStr(I+1:))
		I = I+Str2Str('; shift ='	, cStr(I+1:))+1
		I = I+Int2Str(kshift		, cStr(I+1:))
		I = I+Str2Str('; lenbit ='	, cStr(I+1:))+1
		I = I+Int2Str(klenbit		, cStr(I+1:))
		I = I+Str2Str('; sign ='	, cStr(I+1:))+1
		I = I+Int2Str(ksign		, cStr(I+1:))
		I = I+Str2Str('#perm ='		, cStr(I+1:))

		do J=0,kmax-kshift
		    I = I+1
		    if (I .lt. L) I = I+Int2Str(kperm(J), cStr(I+1:))
		end do

		call Say(cSay,'I','Pack',cStr)

		I = iSetFileSpec(cFile)
		I = iPutFileSpec(FIL__TYPE, FIL__TYPE, '.ice')
		I = iGetFileSpec(0,FIL__TYPE,cStr)

		iRecl = nRecl
		if (bOpenFile(iAct0+OPN__NEW, iU, cStr, iRecl)) then

		    nExtra = itrim(cExtra)

		    call ArrI4Copy(2, iVers, nStore)		! Version number in 1st 8 bytes

		    nStore(3) = nOrig				! Original array length
		    nStore(4) = ibit				! # bits in compressed file
		    nStore(5) = kmax
		    nStore(6) = kshift
		    nStore(7) = klenbit
		    nStore(8) = ksign
		    nStore(9) = nExtra				! Length of extra string
		    J = 9

		    I = kmax-kshift+1
		    call ArrI4Copy(I, kperm, nStore(J+1))	! Permutation table

		    I = J+I
		    call ArrI4Zero(nRecl-I, nStore(I+1))	! Clear up to end of nStore

		    iR = 1
		    write (iU, rec=iR) nStore			! Header record

		    nR = iPack/nRecl
		    do I=0,nR-1					! Groups of nRecl elements
			iR = iR+1
			write (iU, rec=iR) (Pack(I*nRecl+J), J=1,nRecl)
		    end do

		    I = nR*nRecl
		    if (iPack .gt. I) then			! Remaining elements (< nRecl)
			call ArrI4Copy(iPack-I, Pack(I+1), nStore)
			I = iPack-I
			call ArrI4Zero(nRecl-I, nStore(I+1))

			iR = iR+1
			write (iU, rec=iR) nStore
		    end if

		    I = 0
		    do while (I+nByte .le. nExtra)
			iR = iR+1
			write (iU, rec=iR) cExtra(I+1:I+nByte)

			I = I+nByte
		    end do

		    if (nExtra .gt. I) then
			cStore = cExtra(I+1:)
			iR = iR+1
			write (iU, rec=iR) nStore
		    end if

		    iU = iFreeLun(iU)

		    ice_write = 1

		end if

	    else
		call Say(cSay,'W','Pack','scratch array Pack not big enough')

	    end if

	else
	    I = Flt2Str(min(1.,packfraction), 3, cStr)
	    call Say(cSay,'W','Pack','compression worse than threshold '//cStr)

	end if

	return
	end