C      
C                     *************
C                     *  X S E L  *
C                     *************
C      
C                    VERSION: DEC 03 1992
C      
C     SELECT & EXPAND FILES FROM THE XTAL LIBRARY XLIB
C     ------------------------------------------------
C
C      
C     Note that the special packing character (SPC) 
C     definition must match that defined in xpac.f      
C      
C
      PROGRAM XSEL    
C
      CHARACTER IPBUF*80,BLNK*80
      CHARACTER NUM*10,HEAD*32,NAME*22,SPC*1
      CHARACTER A*1,B*1,C*1,FLAG*1
      LOGICAL TEST
      DATA SPC/'`'/
      DATA NUM/'0123456789'/
      DATA HEAD/' XSEL: XTAL Select File (Mar 92)'/
C
      OPEN(1,FILE='XTAB',STATUS='UNKNOWN')
      OPEN(2,FILE='XLIB',STATUS='UNKNOWN')
      WRITE(6,'(/A/)') HEAD
      ICHR=80
      BLNK=' '
C
C---- GET THE NEXT FILENAME FROM XTAB    
C
100   READ(1,'(A)',END=550) IPBUF
      IF(IPBUF(1:1).NE.'<') GOTO 100
      IF(IPBUF(7:7).EQ.' ') GOTO 550
      FLAG=IPBUF(2:2)
      NAME=IPBUF(7:28)
      READ(IPBUF,'(68X,I6)') ILIN
      JCHR=0
      LINE=0
C
C---- IF SELECT FLAG IS <NO > OR <   >; SKIP COMPRESSED CODE
C
      IF(FLAG.NE.'n'.AND.FLAG.NE.'N'.AND.FLAG.NE.' ') GOTO 400
200   CALL GETCHR(C,1,ICHR)
      IF(C.NE.SPC) GOTO 200
      CALL GETCHR(C,1,ICHR)
      IF(C.NE.SPC) GOTO 200
      CALL GETCHR(C,1,ICHR)
      IF(C.NE.SPC) GOTO 200
      GOTO 100
C
C---- IF SELECT FLAG IS <YES> OR <***>; EXPAND AND WRITE FILE
C
400   IF(FLAG.EQ.'*') GOTO 410
      INQUIRE(FILE=NAME,EXIST=TEST)
      IF(.NOT.TEST)   GOTO 410
      WRITE(6,'(1X,A)') NAME
      GOTO 200
410   OPEN(3,FILE=NAME,STATUS='UNKNOWN')
420   CALL GETCHR(C,1,ICHR)
      IF(C.NE.SPC) GOTO 440
      CALL GETCHR(A,1,ICHR)
      IF(A.NE.SPC) GOTO 460
      CALL GETCHR(B,1,ICHR)
      IF(B.NE.SPC) GOTO 480
      IF(JCHR.LT.81) CALL PUTCHR(BLNK,81-JCHR,JCHR,LINE)
      CLOSE(3)
      IF(LINE.NE.ILIN) GOTO 500
      WRITE(6,'(1X,A,14H store file of,I6,7H lines.)') NAME,LINE
      GOTO 100
C
440   CALL PUTCHR(C,1,JCHR,LINE)
      GOTO 420
C
460   I=INDEX(NUM,A)
      IF(I.GT.0) GOTO 490
      CALL PUTCHR(C,1,JCHR,LINE)
      CALL PUTCHR(A,1,JCHR,LINE)
      GOTO 420
C
480   CALL PUTCHR(C,1,JCHR,LINE)
      I=INDEX(NUM,B)
      IF(I.GT.0) GOTO 490
      CALL PUTCHR(A,1,JCHR,LINE)
      CALL PUTCHR(B,1,JCHR,LINE)
      GOTO 420
C
490   CALL GETCHR(B,1,ICHR)
      J=INDEX(NUM,B)
      IF(J.EQ.0) GOTO 480
      J=I*10+J-11
      CALL PUTCHR(BLNK,J,JCHR,LINE)
      GOTO 420
C
500   WRITE(6,'(/1X,A,5H ****,I6,29H lines in XLIB does not match,
     *          I6,16H lines expected.)') NAME,LINE,ILIN
550   STOP
      END
C
C     GETCHR -- GET CHARACTER STRING FROM THE XLIB FILE
C
      SUBROUTINE GETCHR(STRG,LEN,ICHR)
      CHARACTER*80  STRG,IPBUF
      SAVE IPBUF
      DO 100 J=1,LEN
      ICHR=ICHR+1
      IF(ICHR.LE.80) GOTO 100
      READ(2,'(A)') IPBUF
      ICHR=1
100   STRG(J:J)=IPBUF(ICHR:ICHR)
      RETURN
      END
C
C     PUTCHR -- PUT CHARACTER STRING INTO OUTPUT FILE BUFFER  
C
      SUBROUTINE PUTCHR(STRG,LEN,JCHR,LINE)
      CHARACTER*80  STRG,OPBUF
      SAVE OPBUF
      IF(JCHR+LEN.LE.80) GOTO 100
      WRITE(3,'(A)') OPBUF
      LINE=LINE+1
      JCHR=0
100   OPBUF(JCHR+1:JCHR+LEN)=STRG(1:LEN)
      JCHR=JCHR+LEN
      RETURN
      END
