C
C	Support subroutines for VMSXTPC
C
C	XTPC_OPEN_W(%REF(NAME),%VAL(ALLOC),%VAL(EXTEND),%VAL(COMPRESS))
C						Open for write (and read)
C	XTPC_OPEN_R(%REF(NAME))			Open for read
C	XTPC_READ(%REF(BUFFER),%REF(SIZE))	Read a record
C	XTPC_WRITE(%REF(BUFFER),%VAL(SIZE))	Write a record
C	XTPC_CLOSE()				Close
C
	INTEGER*4 FUNCTION XTPC_OPEN_W(NAME,VALLOC,VEXTEND,VCOMPRESS)
	IMPLICIT NONE
	STRUCTURE /BUF/
	   UNION
	      MAP
	         BYTE B(65535)
	      END MAP
	      MAP
	         CHARACTER*65535 C
	      END MAP
	   END UNION
	END STRUCTURE
	RECORD /BUF/ NAME
	BYTE VALLOC,VEXTEND,VCOMPRESS
	INTEGER*4 ALLOC,EXTEND
	INTEGER*4 COMPRESS
	COMMON /LZW_COM/ COMPRESS
	INTEGER*4 STAT,STS,STV,L
	STAT=1
	ALLOC=%LOC(VALLOC)
	EXTEND=%LOC(VEXTEND)
	COMPRESS=%LOC(VCOMPRESS)
	L=INDEX(NAME.C,CHAR(0))-1
d	call lib$put_output('XTPC_OPEN_W for '//NAME.C(1:L))
	OPEN(UNIT=1,NAME='.XTPC',DEFAULTFILE=NAME.C(1:L),
	1 TYPE='NEW',FORM='FORMATTED',RECORDSIZE=32767,
	2 INITIALSIZE=ALLOC,EXTENDSIZE=EXTEND,ERR=8)
	GOTO9
8	CALL ERRSNS(,STS,STV,,STAT)
	IF(STS.GT.1)STAT=STS
	IF(STV.GT.1)STAT=STV
9	XTPC_OPEN_W=STAT
d	call output('Return status !8XL',stat,0)
	RETURN
	END
C
	INTEGER*4 FUNCTION XTPC_OPEN_R(NAME)
	IMPLICIT NONE
	STRUCTURE /BUF/
	   UNION
	      MAP
	         BYTE B(65535)
	      END MAP
	      MAP
	         CHARACTER*65535 C
	      END MAP
	   END UNION
	END STRUCTURE
	RECORD /BUF/ NAME
	INTEGER*4 STAT,STS,STV,L
	STAT=1
	L=INDEX(NAME.C,CHAR(0))-1
d	call lib$put_output('XTPC_OPEN_W for '//NAME.C(1:L))
	OPEN(UNIT=1,NAME='.XTPC',DEFAULTFILE=NAME.C(1:L),
	1 TYPE='OLD',READONLY,FORM='FORMATTED',RECORDSIZE=32767,ERR=8)
	GOTO9
8	CALL ERRSNS(,STS,STV,,STAT)
	IF(STS.GT.1)STAT=STS
	IF(STV.GT.1)STAT=STV
9	XTPC_OPEN_R=STAT
d	call output('Return status !8XL',stat,0)
	RETURN
	END
C
	INTEGER*4 FUNCTION XTPC_READ(BUFFER,SIZE)
	IMPLICIT NONE
	INCLUDE '($SSDEF)'
	INCLUDE '($RMSDEF)'
	STRUCTURE /BUF/
	   UNION
	      MAP
	         BYTE B(65535)
	      END MAP
	      MAP
	         CHARACTER*65535 C
	      END MAP
	   END UNION
	END STRUCTURE
	RECORD /BUF/ BUFFER,TEMP
	INTEGER*4 SIZE
	INTEGER*4 STS,STV,STAT,QLZW_DCM
	INTEGER*4 L,LL
	LOGICAL*1 COMP
d	integer*4 jcomp
	STAT=1
d	call lib$put_output('XTPC_READ')
	READ(1,1,ERR=8)COMP,L,BUFFER.C(1:L)
1	FORMAT(A,Q,A)
2	FORMAT(Q,A)
d	jcomp=comp
d	call output('Read segment: comp !XB length !UL',JCOMP,L)
	IF(L.EQ.32765)THEN
	   READ(1,2,ERR=8)LL,BUFFER.C(32766:LL+32765)
d	call output('Read segment: length !UL',LL,0)
	   L=L+LL
	   IF(LL.EQ.32766)THEN
	      READ(1,2,ERR=8)LL,BUFFER.C(65532:LL+65531)
d	call output('Read segment: length !UL',LL,0)
	      L=L+LL
	   ENDIF
	ENDIF
d	call output('Total read length !UL',L,0)
	IF(COMP)THEN
	   TEMP.C=BUFFER.C
	   STAT=QLZW_DCM(%REF(TEMP.C),L,%REF(BUFFER.C),LL,65535)
	   L=LL
d	call output('Expanded length !UL',L,0)
	ENDIF
	SIZE=L
	GOTO9
8	CALL ERRSNS(,STS,STV,,STAT)
	IF(STS.GT.1)STAT=STS
	IF(STV.GT.1)STAT=STV
9	XTPC_READ=STAT
d	call output('Return status !8XL',stat,0)
	RETURN
	END
C
	INTEGER*4 FUNCTION XTPC_WRITE(BUFFER,VSIZE)
	IMPLICIT NONE
	INCLUDE '($SSDEF)'
	STRUCTURE /BUF/
	   UNION
	      MAP
	         BYTE B(65535)
	      END MAP
	      MAP
	         CHARACTER*65535 C
	      END MAP
	   END UNION
	END STRUCTURE
	RECORD /BUF/ BUFFER,TEMP
	BYTE VSIZE,COMP,NOCOMP
	DATA COMP/1/,NOCOMP/0/
	INTEGER*4 SIZE,ASIZE,L
	INTEGER*4 STS,STV,STAT,QLZW_CMP
	INTEGER*4 COMPRESS
	COMMON /LZW_COM/ COMPRESS
	STAT=1
	SIZE=%LOC(VSIZE)
d	call output('XTPC_WRITE length !UL',SIZE,0)
	IF(SIZE.EQ.0)THEN
	   WRITE(1,2)NOCOMP
2	   FORMAT(A,A)
	   GOTO9
	ENDIF
	IF(COMPRESS)THEN
	   STAT=QLZW_CMP(%REF(BUFFER.C),SIZE,%REF(TEMP.C),L,65535)
	ELSE
	   STAT=2
	ENDIF
d	call output('Compression status !8XL length !UL',STAT,L)
	IF(STAT)THEN
	   IF(L.LT.32765)THEN
	      WRITE(1,2,ERR=8)COMP,TEMP.C(1:L)
d	call lib$put_output('Wrote one compressed segment')
	   ELSE IF(L.LT.65531)THEN
	      WRITE(1,2,ERR=8)COMP,TEMP.C(1:32765)
	      WRITE(1,2,ERR=8)TEMP.C(32766:L)
d	call lib$put_output('Wrote two compressed segments')
	   ELSE
	      WRITE(1,2,ERR=8)COMP,TEMP.C(1:32765)
	      WRITE(1,2,ERR=8)TEMP.C(32766:65531)
	      WRITE(1,2,ERR=8)TEMP.C(65532:L)
d	call lib$put_output('Wrote three compressed segments')
	   ENDIF
	ELSE IF(STAT.EQ.2)THEN
	   IF(SIZE.LT.32765)THEN
	      WRITE(1,2,ERR=8)NOCOMP,BUFFER.C(1:SIZE)
d	call lib$put_output('Wrote one uncompressed segment')
	   ELSE IF(SIZE.LT.65531)THEN
	      WRITE(1,2,ERR=8)NOCOMP,BUFFER.C(1:32765)
	      WRITE(1,2,ERR=8)BUFFER.C(32766:SIZE)
d	call lib$put_output('Wrote two uncompressed segments')
	   ELSE
	      WRITE(1,2,ERR=8)NOCOMP,BUFFER.C(1:32765)
	      WRITE(1,2,ERR=8)BUFFER.C(32766:65531)
	      WRITE(1,2,ERR=8)BUFFER.C(65532:SIZE)
d	call lib$put_output('Wrote three uncompressed segments')
	   ENDIF
	   STAT=1
	ENDIF
	GOTO9
8	CALL ERRSNS(,STS,STV,,STAT)
	IF(STS.GT.1)STAT=STS
	IF(STV.GT.1)STAT=STV
9	XTPC_WRITE=STAT
d	call output('Return status !8XL',stat,0)
	RETURN
	END
C
	INTEGER*4 FUNCTION XTPC_CLOSE()
	IMPLICIT NONE
	CLOSE(UNIT=1)
	XTPC_CLOSE=1
d	call lib$put_output('XTPC_CLOSE, returning success status')
	RETURN
	END
d	subroutine output(format,l1,l2)
d	implicit none
d	character*256 line
d	integer*2 l
d	character*(*) format
d	integer*4 l1,l2
d	call sys$fao(format,l,line,%val(l1),%val(l2))
d	call lib$put_output(line(1:l))
d	return
d	end