PDP-10 Archive: dx/sources/wps2.for from BB-D875A-SM

Trailing-Edge - PDP-10 Archives - BB-D875A-SM - dx/sources/wps2.for
There is 1 other file named wps2.for in the archive. Click here to see a list.
C	       PACKAGE	       :       DX/TOPS20
C	       VERSION         :       V1.0
C	       OP. SYSTEM      :       TOPS20 V3.0
C
C              PROGRAM         :       WLPT
C	       MODULE          :       WPS2.FOR
C	       MODULE #        :       2 OF 12
C	       EDIT            :       002
C	       EDIT DATE       :       17-AUG-78
C
C
C
C**********************************************************************
C
C	       C O P Y R I G H T
C
C
C	COPYRIGHT (C) 1978
C       DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASSACHUSETTS
C
C
C       THIS SOFTWARE IS FURNISHED UNDER A LICENSE FOR USE ONLY  ON  A
C       SINGLE  COMPUTER  SYSTEM  AND  MAY  BE  COPIED  ONLY  WITH THE
C       INCLUSION OF THE ABOVE COPYRIGHT NOTICE.   THIS  SOFTWARE,  OR
C       ANY  OTHER  COPIES  THEREOF,  MAY NOT BE PROVIDED OR OTHERWISE
C       MADE AVAILABLE TO ANY OTHER PERSON  EXCEPT  FOR  USE  ON  SUCH
C       SYSTEM AND TO ONE WHO AGREES TO THESE LICENSE TERMS.  TITLE TO
C       AND OWNERSHIP OF THE SOFTWARE SHALL AT  ALL  TIMES  REMAIN  IN
C       DIGITAL.
C  
C       THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE  WITHOUT
C       NOTICE  AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL
C       EQUIPMENT CORPORATION.
C  
C       DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE  OR  RELIABILITY
C       OF ITS SOFTWARE ON EQUIPMENT THAT IS NOT SUPPLIED BY DIGITAL.
C  
C**********************************************************************
C
C
C
C	E D I T   H I S T O R Y 
C
C  EDIT #000	5/4/78		J. COHEN
C	INITIAL IMPLEMENTATION.
C
C  EDIT #001	7/25/78		T. KENT
C	WHEN A BOLD OR DARK OR UNDERLINED LINE APPEARED ON THE LAST LINE
C	OF A PAGE, THE OVERSTRIKE CHRS WOULD APPEAR ON THE NEXT PAGE.
C	SOME PRINT CONTROL TEXT WOULD BE PRINTED WITHOUT CARRIAGE RETURNS.
C	WHEN DA=DARK, TITLES AND FOOTERS WERE NOT MULTISTRUCK.
C
C  EDIT #002	8/17/78		T. KENT
C	FIX SO THAT WLPT WILL UNDERLINE TABS.
C
C**********************************************************************
C
C
C-------
C	Subroutine SPCHAR is entered whenever a special character
C	({ or |) is found.  The meaning of each of the special
C	character combinations is listed along the right margin
C	as they are dealt with in the code.
C-------
	SUBROUTINE SPCHAR
	INCLUDE 'SPECS.FOR'
90	OCHAR = IBUF(IP)
	CALL INCBUF
	CHAR = IBUF(IP)
	IF (OCHAR.NE.123.OR.CHAR.NE.35) GO TO 100
C-------
C	Following chars are bold			BOLD:	{#
C-------
	BOLD=1
	RETURN
100	IF (OCHAR.NE.123.OR.CHAR.NE.34) GO TO 110
C-------
C	Following chars are normal			NOBOLD: {"
C-------
	BOLD=0
	RETURN
110	IF (OCHAR.NE.123.OR.CHAR.NE.37) GO TO 120
C-------
C	Begin underlining				UNDER:  {%
C-------
	UNDER=1
	RETURN
120	IF (OCHAR.NE.123.OR.CHAR.NE.36) GO TO 130
C-------
C	Stop underlining				NOUNDER:{$
C-------
	IF (ITAB.EQ.0) UNDER=0
	RETURN
130	IF (OCHAR.NE.124.OR.CHAR.NE.73) GO TO 140
C-------
C	Tab char.  The file comes with tabbing
C	already done, so this is ignored,		TAB:	|I
C	except that it is replaced by a space.
C-------
	OBUF(OP) = 32
	IF (UNDER.EQ.1) UBUF(OP) = 95
	OP=OP+1
	ITAB=1
	RETURN
140	IF (OCHAR.NE.124.OR.CHAR.NE.72) GO TO 145
C-------
C	Begin overstriking.  All chars until the
C	end overstrike mark will be overprinted		OVER:	|H
C	on top of each other.
C
C	Note that the following upper limits have
C	been selected:  20 chars per overstrike posi-
C	tion and 20 overstruck chars per line.
C-------
	OVER=1
	CALL INCBUF
	CHAR=IBUF(IP)
	RETURN
145	IF (OCHAR.NE.124.OR.CHAR.NE.77) GO TO 150
C-------
C	Stop overstriking.				NOOVER: |M
C-------
	OVERC=1
	IOV=0
	OVER=0
	OVERN=OVERN+1
	IF (OVERN.GT.OVERMN) OVERMN=OVERN
	IF (OVERN.LE.21) RETURN
	OVERMN=21
	OVERN=1
	WRITE (TTYLUN,148) IPAGE,LINE
148	FORMAT (' Page',I3,', line',I3,': Can''t have more than 20
	1 overstruck'/' characters per line.')
	RETURN
150	IF (OCHAR.NE.123.OR.CHAR.NE.39) GO TO 170
C-------
C	Begin justify mode.  This does not mean
C	to justify the previous line; it effects	JUST:	{'
C	the setting of other switches, though.
C-------
	JUST=1
	RETURN
170	IF (OCHAR.NE.123.OR.CHAR.NE.38) GO TO 180
C-------
C	End justify mode.				NOJUST:	{&
C-------
	JLO(PCON)=OP
	JUST=0
	ITAB=0
	RETURN
180	IF (OCHAR.NE.124.OR.CHAR.NE.74) GO TO 190
C-------
C	This marks the end of a line.			EOL:	|J
C
C	Depending upon other modes in effect, this
C	can have several meanings.
C
C		MODE			EFFECT
C	Justify/Nounderline	Word wrap break between words
C	Justify/Underline	Word wrap break at embedded
C				hyphenation point
C	Superscript		Beginning or end of a paragraph
C	Subscript		Ends a centered line.
C
C	Text comes centered already, so the last code can be
C	ignored.
C-------
	ITAB=0
	IF (SUPER.EQ.1) JUST=0
	JUS=JUSTI
	IF (JUST.EQ.0) JUS=0
	IF (JUST.EQ.0.OR.UNDER.EQ.0) GO TO 189
	OBUF(OP)=45
	OP=OP+1
189	EOL=1
	RETURN
190	IF (OCHAR.NE.124.OR.CHAR.NE.76) GO TO 200
C-------
C	This is the End-of-Page Character.  It has	EOP:	|L
C	special meanings as well.
C
C		MODE			EFFECT
C	No Mode			Indicates new page via "New Page"
C				mark.  (I.e., user forced a new
C				page here.)
C	Justify			Indicates new page via "Page"
C				mark.  (WPS started a new page.)
C	Superscript		Starts PRINT Control info.
C	Subscript		Ends PRINT Control info.
C-------
	IF (SUPER.EQ.1) PCONTR=1
	IF (SUB.EQ.1) PCON=1
	IF (SUPER.EQ.1.OR.SUB.EQ.1) RETURN
	EOP=1
	RETURN
200	IF (OCHAR.NE.123.OR.CHAR.NE.41) GO TO 210
C-------
C	Begin superscripting.				SUPER:	{)
C-------
	SUPER=1
	RETURN
210	IF (OCHAR.NE.123.OR.CHAR.NE.40) GO TO 220
C-------
C	Stop Superscripting.				NOSUPER:{(
C-------
	SUPER = 0
	RETURN
220	IF (OCHAR.NE.123.OR.CHAR.NE.43) GO TO 230
C-------
C	Start Subscripting.				SUB:	{+
C-------
	SUB=1
	RETURN
230	IF (OCHAR.NE.123.OR.CHAR.NE.42) GO TO 240
C-------
C	Stop Subscripting.				NOSUB:	{*
C-------
	SUB=0
	RETURN
240	IF (OCHAR.NE.124.OR.CHAR.LT.59.OR.CHAR.GT.62) GO TO 280
	CHAR = CHAR + "100
250	OBUF(OP) = CHAR
	IF (OVER.EQ.0) OP=OP+1
C-------						{	|;
C	Since the chars { | } ~ have special meanings,  |       |<
C	there are special codes for them when they	}	|=
C	occur in text.					~	|>
C-------
	RETURN
280	IF (OCHAR.NE.124.OR.CHAR.NE.78) GO TO 290
C-------
C	This is the start of a new Ruler.		RULER:	|N
C-------
	CALL RULER
	RETURN
290	IF (OCHAR.NE.124.OR.CHAR.NE.71) GO TO 300
C-------
C	Word Wrap needed - ignore.			WRAP:	|G
C-------
	RETURN
300	WRITE (TTYLUN,301)IPAGE,LINE,OCHAR,CHAR
301	FORMAT (' Internal error:  Page',I3,', line',I3,': Special
	1 character pair ''',2R1,''' is invalid.')
C-------
C	The bad characters are mentioned, but ignored.
C-------
	RETURN
	END
	SUBROUTINE RULER
C-------
C	The RULER routine is called when the start of a new ruler
C	is detected in by SPCHAR.  It absorbs the new information
C	it needs from the ruler and returns when the end of the
C	ruler is found.
C-------
	INCLUDE 'SPECS.FOR'
	OVERLM(PCON) = 0
C-------
C	The ruler is stored as:
C
C	|N old ruler chars @ new ruler chars |O
C
C	The old ruler is skipped over, since it is already known.
C-------
100	IF (IBUF(IP).EQ.64) GO TO 120
	CALL INCBUF
	GO TO 100
C-------
C	Now, begin processing the ruler chars.  These must consist
C	of the symbols A through K or "hex" numeric arguments.
C	The hex character set is:
C
C		0 1 2 3 4 5 6 7 8 9 : ; < = > ?
C-------
120	CALL INCBUF
	NUM=0
	CHAR = IBUF(IP)
	IF (CHAR.LT."60.OR.CHAR.GT."77) GO TO 140
C-------
C	A "hex" char has been found.  Because the char set is in
C	ascending ASCII order, the equivalent number can be found
C	easily.
C-------
	NUM = CHAR - "60
	CALL INCBUF
	IF (IBUF(IP).LT."60.OR.IBUF(IP).GT."77) GO TO 140
	NUM = (NUM*16) + IBUF(IP) - "60
	CALL INCBUF
140	CHAR = IBUF(IP)
	IF (CHAR.LT."101.OR.CHAR.GT."113) GO TO 210
C-------
C	Char is a margin or tab code.  NUM should contain the
C	argument which applies to the code.  Tab codes are
C	ignored because tabbing is already done.
C
C	The type codes are listed in both external and internal format.
C	External format is the character which would appear in the ruler
C	at the WPS station; internal format is the corresponding character
C	which would be scanned for by this program.
C
C	External  Internal
C	 Format    Format
C	   .         A	    Tab aligned on decimal point
C	   >	     B      Tab aligned on right
C	   T	     C      Tab aligned on left
C	   L	     D      Single spaced left margin
C	   R	     E      Ragged right margin
C	   D	     F      Double spaced left margin
C	   J	     G      Justified right margin
C	   W	     H      Word wrap left indent
C	   P	     I      Paragraph indent
C	   C	     J      Explicit centering point
C	   N	     K      1-1/2 spaced left margin
C	   H	     L      Hyphenation Zone on the Ruler
C-------
	IF (CHAR.NE.68) GO TO 150
	SPACE(PCON) = 1+IFIX(FLOAT(EX)/2.+0.5)
	LMAR(PCON) = NUM
	OP=PM
	JLO(PCON)=OP
	GO TO 120
150	IF (CHAR.NE.69) GO TO 160
	RMAR(PCON) = NUM
	JHI(PCON)=NUM+PM
	JUSTI = 0
	GO TO 120
160	IF (CHAR.NE.75.AND.CHAR.NE.70) GO TO 170
	SPACE(PCON) = 2+IFIX(FLOAT(EX)/2.+0.5)
	LMAR(PCON) = NUM
	OP=PM
	JLO(PCON)=OP
	GO TO 120
170	IF (CHAR.NE.71) GO TO 180
	JUSTI = 1
	RMAR(PCON) = NUM
	JHI(PCON)=NUM+PM
	GO TO 120
180	IF (CHAR.NE.72) GO TO 190
	OVERLM(PCON) = NUM
	GO TO 120
190	IF (CHAR.NE.73) GO TO 200
	PARA(PCON) = NUM
	GO TO 120
200	IF (CHAR.NE.74) GO TO 210
	GO TO 120
210	IF (CHAR.NE.124) GO TO 220
	CALL INCBUF
	IF (IBUF(IP).NE.79) GO TO 220
	RETURN
220	IF (CHAR.NE.76) GO TO 228
	GO TO 120
228	IF (CHAR.EQ.65.OR.CHAR.EQ.66.OR.CHAR.EQ.67) GO TO 120
C-------
C	There was an invalid Ruler character.
C-------
	WRITE (TTYLUN,221),IBUF(IP)
221	FORMAT (' Internal error: invalid character ',R1,' in Ruler.')
	GO TO 120
	END
	SUBROUTINE INCBUF
C-------
C	INCBUF simply points IP, the input pointer, at the next
C	character in the input buffer, IBUF.  If the buffer is
C	exhausted it reads a new buffer in from the file.  If
C	end of file is reached it places two nulls in a row in
C	IBUF so the main program will encounter them after it
C	finishes processing the remaining characters.
C-------
	INCLUDE 'SPECS.FOR'
90	IP=IP+1
	IF (IP.GT.LENG) GO TO 100
89	IF (IBUF(IP).GT."37) RETURN
	NN=1
	IBTMP = IBUF(IP) + "100
	WRITE (TTYLUN,91) IBTMP
91	FORMAT (' Internal error:  Control character ^',R1,' found
	1 and ignored.')
	GO TO 90
100	READ (INLUN,110,END=200) LENG,(IBUF(I),I=1,LENG)
110	FORMAT(I2,80R1)
	IP=1
	GO TO 90
200	IBUF(IP)=0
	IBUF(IP+1)=0
	RETURN
	END
	SUBROUTINE CLEAR(ARRAY)
C-------
C	CLEAR places spaces in the array it is supplied with.
C-------
	INCLUDE 'SPECS.FOR'
	INTEGER ARRAY
	DIMENSION ARRAY(200)
	DO 100 I=1,MAXBUF
100	ARRAY(I) = 32
	RETURN
	END
	SUBROUTINE PCONT
C-------
C	PCONT is called to determine whether the Print Control
C	desired is for TOP, BOTTOM or RESET.
C-------
	INCLUDE 'SPECS.FOR'
	DO 100 I=1,MAXBUF
100	IF (OBUF(I).NE.32) GO TO 200
	IP=IP+1
	GO TO 600
200	IF (OBUF(I).EQ.84.OR.OBUF(I).EQ.116) GO TO 300
	IF (OBUF(I).EQ.66.OR.OBUF(I).EQ.98) GO TO 400
	IF (OBUF(I).EQ.82.OR.OBUF(I).EQ.114) GO TO 450
	IF (OBUF(I).EQ.67.OR.OBUF(I).EQ.99) GO TO 500
	TYPE 210,PAGE,LINE,OBUF(I)
210	FORMAT (' Page',I3,', line',I3,': Unrecognized Print Control
	1 command ''',R1,''' ignored.')
	GO TO 505
300	PCON=2
	TP=1
	RMAR(2)=RMAR(1)
	LMAR(2)=LMAR(1)
	IP=IP+1
	GO TO 600
400	PCON=3
	BP=3000
	RMAR(3)=RMAR(1)
	LMAR(3)=LMAR(1)
	IP=IP+1
	GO TO 600
450	PAGE=1
500	PCON=1
C-------
C	Proceed through until the end of Print Control is found.
C-------
505	IF (IBUF(IP).EQ.123) GO TO 510
	CALL INCBUF
	GO TO 505
510	CALL INCBUF
	IF (IBUF(IP).NE.43) GO TO 505
	CALL INCBUF
511	IF (IBUF(IP).NE.124) GO TO 600
	CALL INCBUF
	IF (IBUF(IP).NE.74.AND.IBUF(IP).NE.76) GO TO 600
	CALL INCBUF
	GO TO 511
600	PCONTR=0
	IP=IP-1
	OP=PM
	RETURN
	END
	SUBROUTINE JUSTIF(LO,HI)
C-------
C	JUSTIF justifies the text in OBUF between the limits specified
C	by LO and HI.  It also does concurrent