C*************************************************************************
C  vax_unix.for
C	This program converts an existing FTNMR/DANS file into the 
C	byte-reversed format suitable for shipping (as binary) to 
C	a Unix platform.  
C
C	Tested for an SGI Indigo as destination, but should work
C	for others as well.
C
C	Based on the VAXI3E.FOR supplied by Hare Research with 
C	Felix v.2.06
C
C	Written by:	Ed Sternin, Brock U., Physics
C	Completed:	XII.92
C	Revisions:
C********************************************************** declarations *
	IMPLICIT INTEGER*4 (A-Z)
	PARAMETER (REC_LEN=128)
	INTEGER*4 IN(50000)
	INTEGER*4 OUT(50000)

	character*80	fname
	real*4		in_r(50000)
	equivalence	(in_r,IN)	!same data can be real or integer

	integer*4	icom(32)
        character*128	ccom
        equivalence	(icom,ccom)	! comments field

	character*7	type(2)/'real   ','complex'/,
     1		      domain(2)/'fid    ','ft     '/,
     1			axis(4)/'none   ','pts    ','Hz     ','ppm    '/
C*************************************************************************
C...File names ?
  10	WRITE(6,FMT='(A)') '$ File to convert (VMS format): '
	READ(5,FMT='(A)') fname	
	OPEN(UNIT=1,FILE=fname,STATUS='OLD',FORM='UNFORMATTED',
     1		IOSTAT=IOS,ERR=200)
C
  20	WRITE(6,FMT='(A)') '$ Output to file (Unix format): '
	READ(5,FMT='(A)') fname 	
	OPEN(UNIT=2, FILE=fname,STATUS='NEW',ERR=201,IOSTAT=IOS,
     1		FORM='UNFORMATTED',RECORDTYPE='VARIABLE',RECL=REC_LEN)

	DO WHILE (.TRUE.)				!infinite loop
	    READ(1, END=900) I, (IN(J), J=1, ABS(2*I))	!read a record
	    OUT(1) = SHUFFLE(1*4 + ABS(I)*2*4)		!# bytes/record
	    OUT(2) = SHUFFLE(I)				!header size
	    K = 2
C...if I is negative, then this is a parameter block.  The fixed part of the 
C   record should consist of 16 integers followed by 16 reals.
	    IF (I .LT. 0) THEN
		write(6,*) '  Header size:  ',ABS(2*I),' 4-byte words'
		write(6,*) '  No of points: ',IN(1)
		write(6,*) '  Data type:    ',type(IN(2)+1)
		write(6,*) '  Data domain:  ',domain(IN(3)+1)
		write(6,*) '  Axis type:    ',axis(IN(4)+1)
		write(6,*) '  SW (Hz):      ',in_r(17)
		if(IN(12).NE.0) THEN        ! have a comments field
	  	   DO J=1,IN(12)    
              	      ICOM(J)=IN(IN(11) - 1 + J)
		   END DO
		   write(6,*)'  Comments (may not translate correctly!):'
		   write(6,'(X,A80)') ccom
		else
		   write(6,*) '  Comments:     none'
		end if
	    	DO J=1, 16				!integers
		    K = K + 1
		    OUT(K) = SHUFFLE(IN(J))
		ENDDO
	    	DO J=17, 32				!now the reals
		    K = K + 1
		    OUT(K) = SHUFFLE(CONVERT(IN(J)))
	    	ENDDO
C...DANS quirk: it uses the 20th field to store an integer!
		if(IN(16).eq.'DANS') then
		    OUT(22) = SHUFFLE(IN(20))		!re-write as integer
		    write(6,*) '  DANS FT stadd:',IN(20)
		end if
C...there might also be an optional comments field, or a spectrometer's
C   raw header.  Write out the optional part of the header as integers...
		if(ABS(2*I).gt.32) then		!worry about J=33 here
		  do J=33,ABS(2*I)
		    K = K + 1
		    OUT(K) = SHUFFLE(IN(J))
		  ENDDO
		end if
	    ELSE					!else, it's data block
	    	DO J=1, 2*ABS(I)
		    K = K + 1
		    OUT(K) = SHUFFLE(CONVERT(IN(J)))
	    	ENDDO
	    ENDIF
C...Write the trailing count field
	    K = K + 1
	    OUT(K) = SHUFFLE(1*4 + ABS(I)*2*4)
	    write(6,*) K,'  4-byte words ready for output'

C...Write out in chunks of length REC_LEN
	    NUM_REC = K / REC_LEN
	    LAST_REC_LEN = K - NUM_REC * REC_LEN
	    OFFSET = 1
	    DO J=1, NUM_REC
		CALL WRITE_REC(OUT(OFFSET), REC_LEN)
		OFFSET = OFFSET + REC_LEN
	    ENDDO
	    IF (LAST_REC_LEN .GT. 0)
     1		CALL WRITE_REC(OUT(OFFSET), LAST_REC_LEN)
	ENDDO		!go read the next record
C************************************************************************

900	CONTINUE
	close(2)
	close(1)
	len=index(fname,' ')-1
	write(6,*) '  Transfer using:   rcp '//fname(1:len)//
     1		' unix_host::"~/dir1/subdir/'//fname(1:len)//'"'

	stop '  Done.'

C**************************************************************** errors *
  200   if(IOS.eq.29) then
	   write(6,'(A)') ' File not found'
	else
	   WRITE(6,209) IOS
	   endif
	goto 10
  209	FORMAT (' Input file opening error #',I8)

  201   WRITE(6,209) IOS
  208	FORMAT (' Output file opening error #',I8)
	goto 20

	END
C*********************************************************** subroutines *
	INTEGER FUNCTION CONVERT(XIN)
C
	IMPLICIT INTEGER (A-Z)
	X = XIN
C...Extract the lower 16 bits of the significand
	TEMP1 = IBITS(X, 16, 16)
C...Extract the upper 7 bits of the sigficand and shift them left 23 places
	TEMP2 = ISHFT(IBITS(X, 0, 7), 16)
C...Combine the 23 bits of the significand
	TEMP1 = IOR(TEMP1, TEMP2)
C...Extract the 8 bit exponent
	TEMP2 = IBITS(X, 7, 8)

C If the exponent is zero then don't change it, since both DEC and IEEE formats
C use an exponent of zero when the floating point value is zero.  Otherwise
C subtract 1 twice.  The first decrement is because the DEC exponent is excess
C 128 and the IEEE is excess 127.  The second decrement is because the DEC 
C significand has a range of 0.5 <= SIG < 1 while the IEEE significand has the
C range 1 <= SIG < 2.
	IF (TEMP2 .NE. 0) TEMP2 = TEMP2 - 2
C...Shift the exponent value left 23 places
	TEMP2 = ISHFT(TEMP2, 23)
C...Transfer the sign bit
	IF (BTEST(X, 15)) TEMP2 = IBSET(TEMP2, 31)
C...Combine the exponent and the significand
	CONVERT = IOR(TEMP1, TEMP2)
	RETURN
	END
C*************************************************************************
	INTEGER FUNCTION SHUFFLE(I)
	IMPLICIT INTEGER(A-Z)
C
	TEMP1 = ISHFT(IBITS(I, 0, 8), 24)
	TEMP2 = ISHFT(IBITS(I, 8, 8), 16)
	TEMP3 = ISHFT(IBITS(I, 16, 8), 8)
	TEMP4 = IBITS(I, 24, 8)
	TEMP1 = IOR(TEMP1, TEMP2)
	TEMP3 = IOR(TEMP3, TEMP4)
	SHUFFLE = IOR(TEMP1, TEMP3)
C
	RETURN
	END
C***********************************************************************
	SUBROUTINE WRITE_REC(RECORD, LEN)
	INTEGER RECORD(LEN)
C
	WRITE(2,ERR=99) RECORD
	RETURN
  99	write(6,'(A)') '  Warning: error writing to a file, continuing'
	return
	END