C
C
C       XPAC : Program for writing the compressed XLIB file
C       ---------------------------------------------------
C                     VERSION: DEC 03 1992
C
C       XPAC reads the PACK file which contains the filenames
C       of those files to be packed into the library file XLIB.
C       After a file has been added to XLIB the number of input
C       lines are appended to the PACK line which output to the
C       file XTAB which is the table of contents file sent out
C       with XLIB. The number of lines provide a checksum for
C       selection program xsel.f
C
C       Note that any occurence of the special packing character
C       (SPC), as defined in BOTH XPAC and the subroutine GETCHR
C       below, will be blanked in XLIB.
C
C 
C
      PROGRAM XPAC
C
      CHARACTER IPBUF*80,SPC*1
      CHARACTER HEAD*24,NUM*10,NAME*22
      LOGICAL TEST
      DATA SPC/'`'/
      DATA NUM/'0123456789'/
      DATA HEAD/' XLIB Generator (Sep/90)'/
C
      WRITE(6,'(/A/)') HEAD
      OPEN(1,FILE='PACK')
      OPEN(2,FILE='XTAB')
      OPEN(3,FILE='XLIB')
      JCHR=0
C
C---- READ A FILENAME FROM THE PACK FILE
C
100   READ(1,'(A)',END=500) IPBUF
      IF(IPBUF(1:1).EQ.'<') GOTO 120
      WRITE(2,'(A)') IPBUF
      GOTO 100
120   NAME=IPBUF(7:28) 
      IF(NAME(1:1).EQ.' ') GOTO 500
      INQUIRE(FILE=NAME,EXIST=TEST)
      IF(.NOT.TEST) GOTO 400
      OPEN(4,FILE=NAME)
      LINE=0
      ICHR=80
C
C---- LOOP OVER CHARACTERS IN ALL LINES 
C
200   CALL GETCHR(C,NCHR,ICHR,LINE)
      IF(NCHR.EQ.0) GOTO 300
      IF(NCHR.EQ.1) GOTO 280
      IF(NCHR.LT.4) GOTO 260
      I=NCHR/10
      J=NCHR-I*10
      CALL PUTCHR(SPC//NUM(I+1:I+1)//NUM(J+1:J+1),3,JCHR)
      GOTO 200
260   CALL PUTCHR('   ',NCHR,JCHR)
      GOTO 200
280   CALL PUTCHR(C,1,JCHR)
      GOTO 200
C
C---- CLOSE THE INPUT FILE; WRITE THE XTAB FILE
C
300   CALL PUTCHR(SPC//SPC//SPC,3,JCHR)
      CLOSE(4)
      WRITE(2,'(A,I6,6H lines)') IPBUF(1:68),LINE
      WRITE(6,'(1X,A,I6,22H lines written to XLIB)')NAME,LINE
      GOTO 100
C
400   WRITE(6,'(1X,A,12H is missing!)') NAME
500   IF(JCHR.LT.81) CALL PUTCHR(IPBUF,81-JCHR,JCHR)
      WRITE(2,'(A)') IPBUF
      CLOSE(1)
      CLOSE(2)
      CLOSE(3)
      STOP
      END
C
C     GETCHR -- GET CHARACTER STRING FROM THE DESIGNATED FILE
C
      SUBROUTINE GETCHR(C,LCHR,ICHR,LINE)
      CHARACTER  C*1,IPBUF*80,SPC*1,NUM*10
      DATA NUM/'0123456789'/
      DATA SPC/'`'/
      LCHR=0 
100   ICHR=ICHR+1
      LCHR=LCHR+1
      IF(ICHR.LE.80) GOTO 140
      IF(LCHR.GT.1)  GOTO 160
      ICHR=1
      LCHR=1
      READ(4,'(A)',END=160) IPBUF
      LINE=LINE+1
140   C=IPBUF(ICHR:ICHR)
      IF(C.NE.SPC)  GOTO 150
      IF(IPBUF(ICHR+1:ICHR+1).EQ.SPC)          GOTO 145
      IF(INDEX(NUM,IPBUF(ICHR+1:ICHR+1)).EQ.0) GOTO 150
145   IPBUF(ICHR:ICHR)=' '
      C=' '     
150   IF(C.EQ.' ')  GOTO 100
      IF(LCHR.EQ.1) GOTO 180
160   ICHR=ICHR-1
      LCHR=LCHR-1
      C=' '
180   RETURN
      END
C
C     PUTCHR -- PUT CHARACTER STRING TO XLIB OUTPUT BUFFER  
C
      SUBROUTINE PUTCHR(STRG,LEN,JCHR)
      CHARACTER*80  STRG,OPBUF
      DO 100 I=1,LEN
      JCHR=JCHR+1
      IF(JCHR.LE.80) GOTO 100
      WRITE(3,'(A)') OPBUF
      JCHR=1
100   OPBUF(JCHR:JCHR)=STRG(I:I)  
      RETURN
      END
