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