      function squeez(marr,ihd)
c---    compress the file mapped in MARR into the IDL floating array 
c---    pointed to by NSYM.
c---	IHD (I*4) on input is flag to indicate whether user wants header,
c---	and on output (if header is to be returned) will contain 
c---	the address of the header array
c
	implicit integer*4 (a-z)
        integer*2 marr(*),dumhd(256)	!data array & dummy header
	real*4	temp,tempa,repeat,xq,yq
        integer*4 loop_order(4),idim(6),squeez,compact,itdim(6)
	integer*4	for_gettmp,crearr,for_getdims,darr,p
c
	PARAMETER (TYP_INT = 2, TYP_FLOAT = 4)
c
c---	squeez ought never to finish without a return value.
c---	R. Nakatsuka, 07 Apr 1993.
	squeez=-9		!initialize with default failure code
c
        nx=marr(142)		!number of x positions
        ny=marr(143)		!number of y positions
        np=marr(84)+1		!polarimeter position
        nw=marr(78)+1		!wavelength positions
        nd=marr(61) 		!number of detectors
	nx=max0(nx,1)
	ny=max0(ny,1)
	if (nd.le.0) then
	type *,'SQUEEZ-F-bad detector count in UVSP data file'
	return
	endif
c
c   Now find real repeat count (not what Junior was told to do in MARR(82)).
c
	temp=float(int4(marr(29)))	!shortcut
c--	however, we check if this value of temp makes any sense
c	if not we just use nr*id1*id2
	yq=float(marr(98))*float(marr(99))
	xq=float(marr(20)-nd)*yq
	if (temp.le.xq) then
	   type *,'%SQUEEZ-W-Warning, bad total count in file header'
	   type *,'count = ',temp
	   temp=yq*float(marr(20))
	   type *,'check = ',xq
	   type *,'assume  ',temp
	endif
c
c	this is not a fatal error, so we'll continue to see how far we get.
c
      temp=temp/float(nd)
      tempa=float(nx)*float(ny)*float(np)*float(nw)
c
c  	 now divide by total points per loop
c
      repeat=temp/tempa
      if(amod(temp,tempa).ne.0)repeat=repeat+1
      nr=int(repeat)
      idim(1)=nx
      idim(2)=ny
      idim(3)=nw
      idim(4)=np
      idim(5)=nr
      idim(6)=nd
	tmpsqu = for_gettmp (TYP_FLOAT)		!Declare IDL var.
	call crearr(%val(tmpsqu),6,idim)	!get IDL an array
	ndims=0					!get add. of array
	call for_getdims(%val(tmpsqu),ndims,idim,p)
c
c	also create a header array
c
	if (ihd) then
	   ihd = for_gettmp (TYP_INT)	!dcl IDL var. for exp. header
	   call crearr(%val(ihd),1,256)
	   call for_getdims(%val(ihd),nhd,jhd,iah)
	   istat=compact(%val(p),nx,ny,nw,np,nr,nd,marr,%val(iah))
	else
	   istat=compact(%val(p),nx,ny,nw,np,nr,nd,marr,dumhd)
	endif
c
c	copy to output variable and delete temp. vars.
c	   NOTE: due to weird problems, the header is not copied
c	         here, but is copied instead in the higher level UVSPRD
c
	call copyvar(%val(tmpsqu),itmp)
	squeez = %loc(itmp)
c
        return
	end
c
c            #
c #############
c ##############
c #############		
c            #  
c
      function compact(rarr,nx,ny,nw,np,nr,nd,marr,ihd)
c--	Warning !! - modified by dick shine to work only for i*2 input
c--	some counters changed. some comments and descriptions may be invalid
c--	loop structures modified (simplified) etc.
c
	integer*4 compact
        real*4 rarr(nx,ny,nw,np,nr,nd),dt(6)
        integer*2 ihd(256)
        integer*2 marr(*)
c
c LOCAL
c
        integer*2 iq
        integer*4 lpo(6),nmax(6),in(6),geti
	equivalence (lpo(1),j1),(lpo(2),j2),(lpo(3),j3),(lpo(4),j4)
	equivalence (lpo(5),j5),(lpo(6),j6)
        data lpo(5),lpo(6)/5,6/
	data	ct/0.016/
c
c Now compute
c     a) #blks/rec (not including record header)  (NBLKR)
c     b) total number of records (NRECTOT)
c     c) #elements/record  (NRSZ) 
c
c Other variables used:
c     NABS  absolute index containing data point 
c
c Initialize...
c
c fill LPO - value of LPO(n) becomes the subscripts of the indices for
c            rearranged array - hence it gives the order in which to
c            increment RARR's indices.  
c
	compact=1		!ASSUME SUCCESS
c--	first load the header to be returned
	do i=1,256
	ihd(i)=marr(i)	!=ih(i)
	enddo
      lpo(1)=ihd(57)+1     !corresponds to raster X 
      lpo(2)=ihd(58)+1     !raster Y 
      lpo(3)=ihd(59)+1     !wld 
      lpo(4)=ihd(56)+1     !p 
      j=lpo(1)+lpo(2)+lpo(3)+lpo(4)
      if(j.ne.10)then      !something wrong with header - fill with standard
        do i=2,4           !order 4-1-2-3
           lpo(i)=i-1
        enddo
        lpo(1)=4
      endif
c
      nmax(lpo(1))=nx
      nmax(lpo(2))=ny
      nmax(lpo(3))=nw
      nmax(lpo(4))=np
      nmax(lpo(5))=nr
      nmax(lpo(6))=nd
c
c
c--	always fill the last repeat with zeros for data and end time for times
	do idet=1,nd
	do i3=1,np
	do i2=1,nw
	do i1=1,ny
	do i= 1,nx
	rarr(i,i1,i2,i3,nr,idet)=0.0
	enddo
	enddo
	enddo
	enddo
	enddo
      nrsz=ihd(98)     
      nrsz=nrsz*ihd(99)           !num data points/record
      nblkr=(nrsz-1)/256+1      !num blks/record (not incl rec header)
      nrectot=ihd(20)             !number of records in file
c
	do idet=1,nd	!no times (or new times to be done later)
c--	always reset linda's counters for each det.
	   do j=1,5
               in(j)=1
           enddo
	   do i1=idet-1,nrectot-1,nd
	      nabs=i1*256*(nblkr+1)+257 	!point to record header
c check record header for synch
	      iq=marr(nabs)
              if(iq.ne.'144444'o)then
              type *,'%COMPACT-F-Error in record ',i1,
     &               '  Record synch incorrect'
              compact=42
           return
        endif
c---	the number of points stored in a normal record
	nrsz=marr(nabs+2)*marr(nabs+3)
	if (i1.ge.(nrectot-nd)) then
c--	look at # of data points in this record, this may be less than
c	normal for the last sets of records
	nrsz=marr(nabs+5)	!this is ir(6), normally =ihd(98)*ihd(99)
	endif
c	type *,' nrsz = ',nrsz
         nabs=nabs+256           !point at first datum of record
c
c Since the standard UVSP record structure is such that each record
c corresponds to a different detector in the loop, we will increment
c the detector (outermost index in the rearranged array) here, rather
c than with the inner loops below.  Note also that the repeat count 
c must be reevaluated here in case the size of each data record is not 
c the product of the four inner loops (XYWP) but is some product of
c X,Y,W,P, and fraction*R. (As is the case with V14398.FD)
c
c         in(6)=in(6)+1
c         if(in(6).gt.nmax(6))then
c            in(6)=1
c         else
c            in(5)=llr
c         endif
c         llr=in(5)   !reset for next loop
c         do i2=1,nblkr-1         !process each record blk by blk
c            do i3=1,nelm_in_blk  !process element by element in each blk 
c--	note that we combine linda's loooops into one
c	apparently for historical reasons, the original code took the total
c	count of elements, carefully divided it up and then carefully looped
c	over the so divided quantities to get the total number again !
	do i2=1,nrsz
c-	note that linda's options for byte or floating input have been removed
	fq=float(marr(nabs))
	if (fq.lt.0.0) fq=fq+65536.
               rarr(in(lpo(1)),in(lpo(2)),in(lpo(3)),in(lpo(4)),
     &              in(lpo(5)),idet)=fq
               nabs=nabs+1     
c--	lacking moral courage, dick shine has not tried to improve this
c	section of the code except to remove the now unneccessary GOTO's
      in(1)=in(1)+1
      if(in(1).gt.nmax(1))then
         in(1)=1
         in(2)=in(2)+1
         if(in(2).gt.nmax(2))then
            in(2)=1
            in(3)=in(3)+1
            if(in(3).gt.nmax(3))then
               in(3)=1
               in(4)=in(4)+1
               if(in(4).gt.nmax(4))then
                  in(4)=1
                     in(5)=in(5)+1   !saving repeat for last 
                     if(in(5).gt.nmax(5))then
c              check for array out of bounds
			if (i2 .lt. nrsz) then
                           type *,'%COMPACT-W-array out of bounds! '
			   compact=0
			   return
			endif
                     endif
c***************** endif
               endif
            endif
         endif
      endif
              enddo	!end of i1 loop
c process last (possibly partially filled) block for each record
c-	we already did this
           enddo	!end of i1 loop
	enddo	!end of idet loop
c
c---	end of two major segments
        return
	end
