      PROGRAM LIS2LPS
C UTILITY TO CONVERT .lis files (or other ascii files) to 
C A4 formatted files that can be printed on a laserprinter
C
C A.L.Spek - Utrecht University, The Netherlands (2000)
C
      CHARACTER LINE*80
      LUA = 1
      LUB = 2
      JARG = IARGC()
      IF (JARG .GT. 0) THEN
        CALL GETARG (1, LINE)
        OPEN (LUA, FILE = LINE, STATUS='UNKNOWN')
        KD = INDEX (LINE, '.')
        LINE(KD:) = '.lps'
        OPEN (LUB, FILE = LINE, STATUS = 'UNKNOWN')
        NPAG = 1
        CALL GEN089 (LUA, LUB, NPAG, 51)
      ELSE
        WRITE (6, 99999)
      ENDIF
99999   FORMAT (/, 'Program to convert lineprinter into PostScript',
     1             ' structured file', //,
     2             ' A.L.Spek, Utrecht University, The Netherlands',
     3             ' (2000)', //, 'usage: lis2lps name.lis', //,
     4             'output: name.lps', //,
     5             'both ''name'' and ''lis'' can be substituted',
     6             //)
      END


      SUBROUTINE GEN089 (LUA, LUB, NPAG, NLM)
      CHARACTER NULL*1, ICH*1, PRBUF*132, PSBUF*250
C
C ADOBE POSTSCRIPT
C
      NULL = CHAR(0)
      WRITE (LUB, 99999) 
      WRITE (LUB, 99998)
      NB = 1
      NE = 132
      NP = 0
      NL = NLM 
   10 READ (LUA, 99995, END = 30) PRBUF
      IF (PRBUF(1:1) .EQ. CHAR(12)) THEN
        BACKSPACE LUA
        READ (LUA, 99994, END = 10) PRBUF
        NP = NP + 1
        IF (NP .GT. 1) WRITE (LUB, 99996)
        WRITE (LUB, 99997) NP, NP
        NL = 0 
      ENDIF
      NL = NL + 1
      IF (NL .GE. NLM) THEN
        NP = NP + 1
        IF (NP .GT. 1) WRITE (LUB, 99996)
        WRITE (LUB, 99997) NP, NP
        NL = 1
      ENDIF
      N = 0
      CALL TOPS1 (1, PRBUF, 1, 132, NB, NE)
      DO 20 I = 1, NE
        ICH = PRBUF(I:I)
        IF (ICH .NE. NULL) THEN
          IF (ICH .EQ. '(' .OR. ICH .EQ. ')') THEN
            N = N + 1
            PSBUF(N:N) = CHAR(92)
          ENDIF
          N = N + 1
          PSBUF(N:N) = ICH
        ENDIF
   20 CONTINUE
      WRITE (LUB, 99993) PSBUF(1:N)
      GOTO 10
   30 WRITE (LUB, 99992)
      RETURN
99999 FORMAT ('%!PS-Adobe-2.0', /,'%%Creator: PLATON - A.L.Spek', /,
     1  '%%BoundingBox: 0 0 612 792', /, 
     2  '%%PageOrder: Ascend', /, '%%EndComments', /,
     3  '%%BeginSetup', /,
     3  ' /FONT (Courier) cvn def', /,
     4  ' /FONT_SIZE 9.000000 def', /,
     5  ' /XLMARGIN 25 def', /,
     6  ' /XRMARGIN 10 def', /,
     7  ' /YPAGE 612 def', /,
     8  ' /XPAGE 792 def', /,
     9  ' /YTMARGIN 30 def', /,
     *  ' /YBMARGIN 10 def', /,
     1  ' /PAGENUM 1 def', /,
     2  ' /bd {bind def} bind def', /,
     3  ' /m {moveto} bd ', /,
     4  ' /gs {gsave} bd', /,
     5  ' /gr {grestore} bd',
     6  ' /tr {translate} bd', /,
     7  ' /rt {rotate} bd', /,
     8  ' /PAGES_PER_SHEET 1 def') 
99998 FORMAT (
     1  ' /sp {/SAVEOBJ save def gs 0 XPAGE tr -90 rt } bd', /,
     2  ' /np { gr showpage SAVEOBJ restore sp bp} bd', /,
     3  ' FONT findfont FONT_SIZE scalefont setfont', /,
     4  ' /FONT_UPPER currentfont', /,
     5  ' /FontBBox get 3 get 0 exch currentfont', /,
     6  ' /FontMatrix get transform exch pop def', /,
     7  ' /FONT_LOWER currentfont', /,
     8  ' /FontBBox get 1 get 0 exch currentfont', /,
     9  ' /FontMatrix get transform exch pop def', /,
     *  ' /FONT_HT  FONT_UPPER FONT_LOWER sub def', /,
     1  ' FONT_HT 0 eq {/FONT_HT FONT_SIZE def } if', /,
     2  ' /FONT_MOVE FONT_SIZE FONT_HT gt {FONT_SIZE def}', 
     3  ' {FONT_HT def} ifelse', /,
     4  ' /FONT_TOL FONT_HT YBMARGIN add def', /,
     4  ' /bp { XLMARGIN YPAGE YTMARGIN sub FONT_UPPER sub m } bd', /,
     5  ' /s { show  currentpoint exch pop dup FONT_TOL', 
     6  ' gt {FONT_MOVE sub XLMARGIN  exch m} {np} ifelse}  bd', /,
     7  '%%EndSetup', /, 'sp', /, 'bp') 
99997 FORMAT ('%%Page:', 2I7)
99996 FORMAT ('np')
99995 FORMAT (A)
99994 FORMAT (1X, A)
99993 FORMAT ('(', A, ')s')
99992 FORMAT ('np', /, '%%EOF')
      END
      SUBROUTINE TOPS1 (MODE, LINE, LB, LE, NB, NE)
      CHARACTER LINE*(*)
C MODE = -1 STRIP HEADER BLANKS,
C MODE =  1 STRIP TRAILING BLANKS
C MODE =  0 STRIP HEADER & TRAILING BLANKS
      NB = LB
      NE = LE
      IF (MODE .GE. 0) THEN
        N = LE - LB + 1
        K = LE + 1
        DO 10 I = 1, N
          K = K - 1 
          IF (LINE(K:K) .NE. ' ') GOTO 20
   10   CONTINUE
   20   NE = K 
      ENDIF
      IF (MODE .LE. 0) THEN
        N = NE - LB + 1
        K = LB - 1
        DO 30 I = 1, N  
          K = K + 1 
          IF (LINE(K:K) .NE. ' ') GOTO 40
   30   CONTINUE
        K  = K + 1
   40   NB = K
      ENDIF
      RETURN
      END
