SV1
  29
AMONTHSRC
BEEPER001
EDITCDSRC
GETW@@SRC
INIT@@001
INITDS001
LEGOP@SRC
LETTERSRC
LEVEL@SRC
LISTN@SRC
LJI@@@SRC
LOGON@001
LOWER@001
NEWPAGSRC
POPUP@SRC
PUTL@@SRC
PUTW@@SRC
READI@001
RESET@SRC
RJI@@@SRC
SETUIC001
SPECS@SRC
SPRINTSRC
SRCSPCSRC
SYSDAY001
TRIM@@SRC
WRITEI001
WRITEL001
YES@@@SRC
[\].
AMONTHSRC
C  AMONTH SRC						AMONTH  SRC
C  26 FEB 74						26 FEB 74
C
	                FUNCTION AMONTH(I)
C
C
C  PURPOSE:
C
C  TO RETURN A 3 CHARACTER ABBREVIATION OF THE "I"-TH MONTH
C  OF THE YEAR.  IF THE NUMBER IS ILLEGAL, A BLANK IS RETURNED
C
	DIMENSION ABR(13)
C
	DATA ABR /3HJAN,3HFEB,3HMAR,3HAPR,3HMAY,3HJUN,
	1         3HJLY,3HAUG,3HSEP,3HOCT,3HNOV,3HDEC,3H   /
C
C.........................................................................
C
	J = I
	IF (J.LE.0.OR.J.GE.13) J = 13
	AMONTH = ABR(J)
	RETURN
	END
[\].
BEEPER001
	.TITLE	BEEPER "BEEPS" THE VT05 VIA LTS.
/
VT05=4
MODE=3	/USE IMAGE MODE WRITE
/
	.GLOBL	BEEPER
BEEPER	0	/ENTRY POINT
	.WAIT  VT05
	.WRITE VT05,MODE,BUFFER,2
	.WAIT  VT05
	JMP*	BEEPER
/
BUFFER	3002
	0000
	0000
	0007
	0177
	0177
/
	.END
[\].
EDITCDSRC
C  EDITCD SRC						EDITCD SRC
C  17 FEB 74						17 FEB 74
C
                        SUBROUTINE EDITCD
C
C  CARD EDITOR FOR SPECS
C
C    THE EDITOR WILL ACCEPT THE FOLLOWING COMMANDS
C	D LINE# - DELETE THIS LINE NUMBER
C	- LINE# - CONTINUE DELETING THROUGH THIS NUMBER
C	E       - END OF INPUT DECK
C	I LINE# - INSERT THIS CARD AFTER LINE NUMBER
C	        - CONTINUE INSERTING
C	R LINE# - REPLACE THE LINE WITH THIS CARD
C
C    IN ADDITION, THE CARDS CAN BE INTERPRETED FOR UPPER AND
C    LOWER CASE CHARACTERS.  ALL CHARACTERS ARE ASSUMED TO  BE
C    LOWER CASE UNLESS A "SHIFT" CHARACTER IS ENCOUNTERED.  THE
C    SHIFT CHARACTERS USED ARE
C	_ : SHIFT THE NEXT CHARACTER (SHIFT)
C	< : SHIFT LOCK
C	> : SHIFT UNLOCK
C
C
C
	IMPLICIT INTEGER (A-Z)
C	******** ******* *****
C
	REAL REPLY,BLANKS,TEMPS
	REAL EDITF(2),ORIGF(2),TEMPF(2),RNAME(2)
C
	LOGICAL COPY,INSERT,GOOD
	LOGICAL LEGNUM,LEGOP,KEEPIT,YES
C
	DIMENSION NULINE(85),LINE(85),CARD(85),EXTRA(85)
C
	COMMON /SLOTS/ IDK1,IDK2,LTA,ICD,LPS
C
C  ASCII CONTROL CHARACTERS
	DATA BLANK,CR,EOF /#040,#015,#005/
	DATA UP,DN,SH /#074,#076, #137/
	DATA I1,RE,END /#111,#122,#105/
	DATA D1,D2     /#104,#055/
C
C  FILE CONTROL TEXT
	DATA BLANKS,TEMPS /5H     ,5H.TEMP/
	DATA  EDITF(2),ORIGF(2),TEMPF(2) /3*4H SPC/
C
C.........................................................................
C  TEST FUNCTIONS
C  OPERATION CODES:
C    LEGOP(X) = .T. IF X IS ONE OF (BLANK,<,>,D,E,I,R,-)
C
C  NUMBERS
	LEGNUM(NO) = ((#60.LE.NO).AND.(NO.LE.#71)).OR.(NO.EQ.BLANK)
C  KEEP THIS LINE
	KEEPIT(NO) = (NO.LT.LPOINT.AND.COPY).OR.(CODE.EQ.I1)
C..................................................................
C
C  SET-UP SECTION.
C
	IERR = LPS
C    FIND AND INITIALIZE FILES
C
100	CONTINUE
	WRITE (LTA,101)
101	FORMAT ("1  EDIT SPEC FILE")
C
C  INPUT FILE
	WRITE (LTA,105)
105	FORMAT ("0  WHAT IS THE NAME OF THE ORIGINAL SPEC FILE?")
C
110	READ (LTA,115) REPLY
115	FORMAT (A5)
	IF (REPLY.EQ.BLANKS) GO TO 900
C
	ORIGF(1) = REPLY
	CALL FSTAT(IDK1,ORIGF,ISIT)
	CALL CLOSE(IDK1)
	IF (ISIT) GO TO 120
C  ..NO INPUT FILE FOUND
	CALL BEEPER
	WRITE (LTA,116)
116	FORMAT ("    FILE NOT FOUND.  PLEASE RETYPE NAME")
	GO TO 110
C
C  OUTPUT FILE NAME
120	CONTINUE
	WRITE (LTA,125)
125	FORMAT ("0  WHAT IS THE NAME OF THE NEW SPEC FILE?")
	READ (LTA,115) REPLY
	IF (REPLY.EQ.BLANKS) REPLY = TEMPS
	TEMPF(1) = REPLY
C
C  EDIT DECK FILE NAME
130	CONTINUE
	WRITE (LTA,135)
135	FORMAT ("0  WHAT IS THE NAME OF THE EDIT SEQUENCE?")
140	READ (LTA,115) REPLY
	IF (REPLY.EQ.BLANKS) GO TO 900
	EDITF(1) = REPLY
	CALL FSTAT(ICD,EDITF,ISIT)
	CALL CLOSE(ICD)
	IF (ISIT) GO TO 150
C  ..NO EDIT FILE FOUND
	CALL BEEPER
	WRITE (LTA,116)
	GO TO 140
C
C  INITIALIZE FILES AND POINTERS
150	CONTINUE
	CALL INIT(IDK1,0)
	CALL SEEK(IDK1,ORIGF)
C
	CALL INIT(ICD,0)
	CALL SEEK(ICD ,EDITF)
C
	CALL INIT(IDK2,1)
	CALL ENTER(IDK2,TEMPF)
C
	LNUMBR = 0
C
	WRITE (LTA,155)
155	FORMAT ("0  EDIT IN PROGRESS.  PLEASE WAIT")
C
C
C  CARD INPUT SECTION
C
200	CONTINUE
C
C  CLEAR BUFFERS
	CALL RESET(CARD,81)
	CALL RESET(NULINE,85)
C
C  ARE THE CARDS FINISHED?
	IF (CODE.EQ.END) GO TO 400
C  READ A CARD
	CALL READI(ICD,CARD)
	HEADER = POPUP(CARD)
	WCOUNT = POPUP(CARD)
	CALL TRIM(CARD)
C  ..COPY THE CARD IMAGE INTO EXTRA FOR ERROR MESSAGE
	DO 205  J=1,81
	EXTRA(J) = CARD(J)
205	CONTINUE
C
C  GET THE OP-CODE (CHAR #1)
	CODE = POPUP(CARD)
C  TEST FOR LEGALITY
	IF (LEGOP(CODE)) GO TO 220
C  ..BAD OP-CODE
	WRITE (IERR,210)
210	FORMAT ("0  THE FOLLOWING CARD HAS A BAD EDIT CODE")
	GO TO 380
C
C    DECODE THE INTEGER FIELD INTO A NUMBER (CHARS #2 THROUGH #8)
220	CONTINUE
	LPOINT = 0
	GOOD = .TRUE.
	DO 230  J=2,7
	CAR = POPUP(CARD)
	IF (CAR.EQ.CR) GO TO 231
	GOOD = GOOD.AND.LEGNUM(CAR)
	IF (CAR.NE.BLANK .AND. GOOD) LPOINT = 10*LPOINT + (CAR - #60)
230	CONTINUE
C    WAS THE NUMBER "GOOD"?
231	IF (GOOD) GO TO 240
C
C  ..BAD NUMERIC CODE IN THIS CARD
C
	WRITE (IERR,235)
235	FORMAT ("  THE FOLLOWING CARD HAS A NON-"
	1         "NUMERIC CHARACTER IN THE LINE-NO.")
	GO TO 380
C
C  COPY THE CARD IMAGE INTO THE NULINE BUFFER
240	CONTINUE
	K = 0
	DO 250  J=8,81
	               CAR = POPUP(CARD)
	IF (CAR.EQ.UP) CAR = 0
	IF (CAR.EQ.DN) CAR = -1
	IF (CAR.NE.SH) CALL LOWER(CAR)
	IF (CAR.EQ.SH) CAR = POPUP(CARD)
	IF (CAR.LE. 0) GO TO 250
	               K = K + 1
	               NULINE(K) = CAR
	IF (CAR.EQ.CR) GO TO 260
250	CONTINUE
C
C  DONE THIS CARD
260	CONTINUE
C
C  CHECK THE CARD FOR ILLEGAL ERROR COMBINATIONS.
300	CONTINUE
C
C    THE PROCEDURE IS TO SKIP OVER THE CODE FOR THAT COMBINATION
C    IF THE CONDITIONS FOR LEGALITY ARE NOT MET.
C
C  DELETE SEQUENCE
C  1.  FIRST CARD
310	IF (.NOT.(CODE.EQ.D1.AND.LPOINT.GT.LNUMBR)) GO TO 320
	    COPY = .TRUE.
	    INSERT = .FALSE.
	    LAST = CODE
	GO TO 400
C
C  2.  SECOND CARD
320	IF (.NOT.(LAST.EQ.D1.AND.(CODE.EQ.D2.AND.LPOINT.GT.LNUMBR)))
	1                                    GO TO 330
	    COPY = .FALSE.
	    INSERT = .FALSE.
	    LAST = CODE
	GO TO 400
C
C  INSERT SEQUENCE
C  1.  FIRST CARD
330	IF (.NOT.(CODE.EQ.I1.AND.LPOINT.GE.LNUMBR)) GO TO 340
	    COPY = .TRUE.
	    INSERT = .TRUE.
	    LAST = CODE
	GO TO 400
C
C  2.  SECOND CARD
340	IF (.NOT.(LAST.EQ.I1.AND.(CODE.EQ.BLANK.AND.LPOINT.EQ.0)))
	1                                    GO TO 350
	    COPY= .TRUE.
	    INSERT = .TRUE.
	    LAST = I1
	GO TO 400
C
C  REPLACING A LINE
350	CONTINUE
	IF (.NOT.(CODE.EQ.RE.AND.LPOINT.GT.LNUMBR)) GO TO 360
	    COPY = .TRUE.
	    INSERT = .TRUE.
	    LAST = CODE
	GO TO 400
C
C  CLOSING THE FILE
360	IF (.NOT.(CODE.EQ.END)) GO TO 370
	    COPY = .TRUE.
	    INSERT = .FALSE.
	    LPOINT = #377777
	GO TO 400
C
C
C  ERROR SECTION
370	CONTINUE
	WRITE (IERR,375)
375	FORMAT ("  THE FOLLOWING CARD IS OUT OF SEQUENCE")
C
380	CONTINUE
	WRITE (IERR,381) CODE,LPOINT,LNUMBR
381	FORMAT (/2X,"CODE=",O3," LPOINT=",I4," LNUMBR=",I4)
	CALL WRITEI(IERR,EXTRA)
	WRITE (IERR,385)
385	FORMAT (1X,8("_________I"))
	GO TO 200
C
C
C  FILE MANIPULATION SECTION
400	CONTINUE
C
C  IS THE FILE CORRECTLY POSITIONED
	IF ((DKFLAG.EQ.EOF).OR.(LNUMBR.GE.LPOINT)) GO TO 420
C  OTHERWISE POSITION THE FILE DOING ALL THE COPIES NEEDED
	CALL READI(IDK1,LINE)
STRUCTURE PLANE FRAME DEMO RUN
TYPE PLANE FRAME
NUMBER OF JOINTS 11
NUMBER OF MEMBERS 12
NUMBER OF SUPPORTS 4
NUMBER OF LOADINGS 3
JOINT COORDINATES
1 0. 0. 0.  S
2 192. 0. 0. S
3 384. 0. 0. S
4 576. 0. 0. S
5 0. 240.
6 192. 240.
7 384. 240.
8 576. 240.
9 0. 432.
10 192. 432.
11 384. 432.
JOINT RELEASES
2 MOMENT Z
MEMBER PROPERTIES PRISMATIC
1 THRU 4 25. 0. 0. 0. 0. 900.
5 20. 0. 0. 0. 0. 600.
6 20. 0. 0. 0. 0. 600.
7 15. 0. 0. 0. 0. 400.
8 14. 0. 0. 0. 0. 360.
[\].
GETW@@SRC
C  GETW  SRC					GETW  SRC
C  21 FEB 74					21 FEB 74
C.................................................................
	SUBROUTINE GETW(LINE,N)
C
C  PURPOSE
C    "GETW" GETS THE NEXT WORD FROM THE TEXT BUFFER "INLINE" AND
C    RETURNS IT TO THE USER IN "LINE".  THE VARIABLE "N" HAS THE
C    FOLLOWING VALUES
C    1.  N>0 - "N" IS THE NUMBER OF CHARACTERS IN THIS WORD,
C    2.  N<0 - "N" IS TO BE INTREPRETED AS A CONTROL CHARACTER
C	      FOUND WHEN "GETW" HAD TO READ IN A NEW "LINE"
C    3.  N=-999 - EOF ON INPUT.
C
C
C  DECLARATION SECTION
	IMPLICIT INTEGER (A-Z)
C
	DIMENSION INLINE(85),LINE(85)
C
	COMMON /SLOTS/ IDK1,IDK2,LTA,ICD,LPS
C
C
	DATA PERIOD,COMMA,BLANK,CR /46,44,32,13/
	DATA WORDCT /0/
C...............
C  CHECK TO SEE IF THE INPUT LINE IS EMPTY; IF SO GET A NEW LINE.
	IF (WORDCT.EQ.0) GO TO 30
C       ........
C  POPUP THE INPUT LINE TO GET THE NEX WORD INCLUDING THE TRAILING
C  BLANK AND PUNCTUATION MARKS
1	CONTINUE
	DO 5  J=1,85
	N = J
	CAR = POPUP(INLINE)
	IF (CAR.EQ.CR) GO TO 20
	LINE(N) = CAR
	IF (CAR.EQ.BLANK) RETURN
5	CONTINUE
C...............
C  SETUP TO READ IN A NEW BUFFER LINE
20	CONTINUE
	WORDCT = 0
	LINE(N) = BLANK
	IF (N.GT.1) RETURN
C  NOW READ IN THE NEW BUFFER
30      CONTINUE
	CALL RESET(INLINE,85)
	CALL READI(IDK1,INLINE)
C  GET EOF FLAG AND WORD COUNT.
	HEADER = POPUP(INLINE)
	WORDCT = POPUP(INLINE)
	IF (HEADER.NE.5) GO TO 40
C  EOF ENCOUNTERED.
	WORDCT = 0
	N = -999
	RETURN
C  .......
40      CONTINUE
C  CHECK FOR A CONTROL CHARACTER AT THE HEAD OF THE LINE
	K1 = POPUP(INLINE)
	K2 = POPUP(INLINE)
	IF (K1.EQ.CR) GO TO 30
	IF (K1.EQ.BLANK) GO TO 1
C  A CONTROL CHARACTER WAS ENCOUNTERED
	LINE(1) = LINE(2) = BLANK
	N = -K1
	RETURN
	END
[\].
INIT@@001
	.TITLE	SUBROUTINE INIT(UNIT,IOSW)		5 FEB 1974
	.GLOBL	INIT,.DA
/
/  THIS MACRO ROUTINE FORCES A UNIT TO BE INITIALIZED SINCE
/  THE FORTRAN "SEEK" AND "ENTER" ROUTINEDS DON'T DO IT.
/
SLOT=0	/DUMMY ARGUMENT FOR SLOT NUMBER
MODE=0	/DUMMY ARGUMENT FOR I-O SWITCH
/
INIT	0		/ENTRY
	JMS*	.DA	
	JMP	.+2+1
UNIT	0
IOSW	0		/=0 FOR READ, =1 FOR WRITE
	LAC*	UNIT	/GET UNIT NUMBER
	AND	(777	/MASK IT FOR CAL SLOT
	DAC	WAIT
	LAC*	IOSW	/GET THE DIRECTION SWITCH
	AND	(1	/MASK IT
	SWHA		/MOVE IT TO 1000'S POSITION
	XOR	WAIT	/OR IN THE UNIT
	DAC	INIT1
/
INIT1	.INIT	SLOT,MODE,RETURN
WAIT	.WAIT	SLOT
RETURN	JMP*	INIT
	.END
[\].
INITDS001
	.TITLE	INITDS	5 FEB 1974
	.GLOBL	INITDS
/THIS ROUTINE INITIALIZES THE DAT SLOTS
INPUT=1
LIST=6
READ=0
WRITE=1
/...............
	.IODEV	INPUT,LIST
INITDS	0
	.INIT	INPUT,READ,RETURN
	.WAIT	INPUT
	.INIT	LIST,WRITE,RETURN
	.WAIT	LIST
RETURN	JMP*	INITDS
	.END
[\].
LEGOP@SRC
C  LEGOP SRC						LEGOP SRC
C  19 FEB 74						19 FEB 74
C
                        LOGICAL FUNCTION LEGOP(IT)
C
C  TESTS "IT" TO SEE IF IT IS A LEGAL OPERATION CODE FOR THE
C  EDIT CARDS.  THE LEGAL CHARACTERS ARE
C	"-" : SECOND PART OF DELETION
C	"D" : FIRST PART OF DELETION
C	"E" : END OF CARDS
C	"I" : INSERT ONE CARD
C	"R" : REPLACE
C	" " : CONTINUE INSERTION
C
C
	IMPLICIT INTEGER (A-Z)
C	******** ******* *****
C
C  ASCII CONTROL CHARACTERS
	DATA BLANK,CR,EOF /#040,#015,#005/
	DATA UP,DN,SH /#074,#076, #134/
	DATA I1,RE,END /#111,#122,#105/
	DATA D1,D2     /#104,#055/
C
C.........................................................................
C  OPERATION CODES:
	LEGOP = (IT.EQ.BLANK).OR.(IT.EQ.D1).OR.(IT.EQ.D2).OR.
	1       (IT.EQ.I1).OR.(IT.EQ.RE).OR.(IT.EQ.END)
C
	RETURN
	END
[\].
LETTERSRC
C  LETTER SRC					LETTER SRC
C  11 NOV 1973					11 NOV 1973
C................................................................
        INTEGER FUNCTION LETTER(N)
C
C  PURPOSE
C  LETTER CONVERTS AN INTEGER (1 - 26) TO AN ALPHABETICAL CHARACTER
C  1.   IF N > 0, THE CHARACTER IS AN UPPERCASE ONE
C  2.   IF N< 0, THE CHARACTER IS A LOWER CASE ONE
C  3.   IF ABS(N) > 26, A "*" IS RETURNED.
C...............
        K = 42
        IF (N.GT.0.AND.N.LE.26) K = N + 64
        IF (N.LT.0.AND.N.GE.-26) K = 96 - N
        LETTER = K
        RETURN
        END
[\].
LEVEL@SRC
C  LEVEL SRC				LEVEL SRC
C  10 NOV 73					10 NOV 73
C..................................................................
C
C  PURPOSE:
C  1.  FIND THE CONTROL CHARACTER IN THE INPUT LINE
C  2.  CONVERT IT TO THE TEXT LEVEL INDICATOR
C
C	LEVEL CONVERTION TABLE
C	-----------------------------------------
C	LEVEL	CODE	TEXT
C	  2	$ S	SECTION
C	  3	$ A	ARTICLE
C	  4  	0	PARAGRAPH
C	  5	1	AUB-PARAGRAPH
C	  6	2	SUB-SUB PARAGRAPH
C	  7	3	SUB-SUB-SUB-PARAGRAPH
C	  8	4	SUB-SUB-SUB-SUB-PARAHRAPH
C	  9	@	NO SHUFFLE
C	 10	*	NOTES FOR WORK SHEET
C	-----------------------------------------
C
C
C  ERRORS:
C  1.  AN UNRECOGNIZED CC GIVES A LEVEL = 99
C
C...................................................................
        INTEGER FUNCTION LEVEL(K)
        DIMENSION LINE(85)
C...............
        IF (K.NE.36) GO TO 10
        CALL GETW(LINE,N)
        IF (LINE(1).EQ.83) LET = 2
        IF (LINE(1).EQ.65) LET = 3
        LEVEL = LET
        RETURN
C...............
10	CONTINUE
C  THE CONTROL CHARACTER IS OTHER THAN A "$"
        LET = K
        IF (LET.EQ.48) LET = 4
        IF (LET.EQ.49) LET = 5
        IF (LET.EQ.50) LET = 6
        IF (LET.EQ.51) LET = 7
        IF (LET.EQ.52) LET = 8
        IF (LET.EQ.92) LET = 9
	IF (LET.EQ.64) LET = 9
        IF (LET.EQ.42) LET = 10
        IF (LET.GE.11) LET = 99
        LEVEL = LET
        RETURN
        END
[\].
LISTN@SRC
C  LISTN  SRC						LISTN SRC
C  24 FEB 74						24 FEB 74
C
	                        SUBROUTINE LISTN
C
C  GENERATE A DOUBLE-SPACED LISTING WITH LINE NUMBERS FOR THE
C  WORKING SPECS
C
	IMPLICIT INTEGER (A-Z)
C	******** ******* *****
C
	LOGICAL YES
	REAL REPLY,BLANKS,AMONTH,AMO
	REAL ORIGF(2),TEMPF(2)
C
	DIMENSION INLINE(85),NULINE(100),NFIELD(6)
C
	COMMON /SLOTS/ IDK1,IDK2,LTA,ICD,LPS
C
	EQUIVALENCE (NULINE(2),NFIELD(1))
C
C  CONTROL CHARACTERS
	DATA EOF /#005/
	DATA DBL /#021/
	DATA CR  /#015/
C
C  TEXT NAMES
	DATA BLANKS /5H     /
	DATA ORIGF(2),TEMPF(2) /4H SPC,4H LST/
C..................................................................
C
100	WRITE (LTA,101)
101	FORMAT ("1    SPECS - LIST WITH LINE NUMBERS")
C
C  GET THE FILE NAME
	WRITE (LTA,105)
105	FORMAT ("0 WHAT IS THE NAME OF THE INPUT FILE?")
C
110	READ (LTA,115) REPLY
115	FORMAT (A5)
	IF (REPLY.EQ.BLANKS) GO TO 900
C
	TEMPF(1) = ORIGF(1) = REPLY
	CALL FSTAT(IDK1,ORIGF,ISIT)
CHK
  23
CALDATSRC
CHKOUTSRC
CKACCTSRC
CKAMT@SRC
CKBTCHSRC
CKDATESRC
CKDESCSRC
CKMMC@SRC
CKNUM@SRC
CKREF@SRC
CKSPECSRC
CKTYP@SRC
EDTCHKSRC
FILAMTSRC
FILDAYSRC
GETWKESRC
RDATE@SRC
REGISTSRC
SORTR@SRC
TOTAL@SRC
UMERGESRC
UPTR2@SRC
UPTRANSRC
[\].
LJI@@@SRC
C  LJI SRC					LJI SRC
C  27 OCT 73					27 OCT 73
C.............................................................
	SUBROUTINE LJI(N,LINE,WIDTH)
C
	INTEGER INT(10),LINE(10),WIDTH,BLANK,STAR
C
C  INTEGER CHARACTER REPRESENTATION OF DIGITS 0-9
	DATA INT /48,49,50,51,52,53,54,55,56,57/
C
C  SET THE LINE TO BLANKS AND TEST TO SEE IF THE NUMBER WILL FIT
	IW = 1
	DO 10  J=1,WIDTH
	LINE(J) = BLANK
	IW = 10*IW
10	CONTINUE
	IF (N.LT.IW) GO TO 20
	LINE(1) = STAR
C  PICK UP THE FIRST CHARACTER
20	CONTINUE
	LINE(1) = INT(1)
	IT = N
	K = 1
30	IW = IW/10
	IF (IW.EQ.0) RETURN
	IN = IT/IW
	IF (IN.EQ.0) GO TO 30
C  WE HAVE FOUND THE FIRST CHARACTER; FILL THE LINE
40	CONTINUE
	LINE(K) = INT(IN+1)
	K = K + 1
	IT = IT - IN*IW
	IW = IW/10
	IF (IW.EQ.0) RETURN
	IN = IT/IW
	GO TO 40
	END
[\].
LOGON@001
	.TITLE	LOGON : WRITE LOGON MESSAGE ON TTY
	.GLOBL	LOGON,.DA
SLOT=-2		/SYSTEM TTY
MODE=2		/IOPS ASCII
SIZE=10		/WORD COUNT (=8 DEC.)
WPCN=6		/HEADER WORD PAIR COUNT
/
	.IODEV	SLOT
	.GLOBL	LOGON,.DA
/
LOGON	0
	JMS*	.DA	/GET ADDR
	JMP	.+2
ARRAY	0		/WILL CONTAIN ADDR OF POINTER
	LAC*	ARRAY
	DAC	ARRAY	/NOW POINTS TO FIRST WORD
	LAC	(BUFFER
	DAC	BUFADR#	/PUT IN BUFFER POINTER
	LAW	-SIZE	/FORM COUNTER IN AC
	DAC	COUNT#	
LOOP	LAC*	ARRAY	/GET DATA
	DAC*	BUFADR	/PUT IN BUFFER
	ISZ	ARRAY	/INCREMENT POINTERS
	ISZ	BUFADR
	ISZ	COUNT
	JMP	LOOP
	NOP
	.WRITE	SLOT,MODE,HEADER,6
	JMP*	LOGON
/
HEADER	WPCN*1000
	0		/OTHER HALF OF HEADER PAIR
BUFFER	.BLOCK	SIZE
CR	.ASCII	<015>	/CARRIAGE REUTRN PAIR
	.END
[\].
LOWER@001
	.TITLE	SUBROUTINE LOWER(CHAR)		18 FEB 74
/
/  MACRO ROUTINE TO CONVERT CARD ASCII TO LOWER CASE
/
/    THE ROUTINE ASSUMES THAT CONVERTION IS NORMAL CASE
/
/    IF CAR = 0 (.FALSE.) WE STOP LOWERING
/    IF CHAR=-1 (.TRUE.) WE RESUME LOWERING
/
	.GLOBL	LOWER,.DA
LOWER	0
	JMS*	.DA
	JMP	.+1+1
CHAR	0
	LAC*	CHAR	/GET THE CHARACTERR
	SPA		/SKIP IF AC >= 0
	JMP	CONTRL	/     JUMP FOR CHAR=-1
	SNA		/SKIP AC NOT 0
	JMP	CONTRL	/    JUMP FOR CHAR=0
/
	LAC	SHIFT	/LOAD THE SHIFT FLAG
	SMA		/IF -1, WE WILL LOWER-CASE IT
	JMP*	LOWER
/
	LAC*	CHAR	/REFETCH THE CHARACTER
	TAD	(-101	/SUBTRACT ALPHA BASE
	SPA		/SHIP IF IT MIGHT BE A CHARACTER
	JMP*	LOWER
	TAD	(-32	/SUBTRACT UPPER BOUND
	SMA		/IF <0, IT'S A CHARACTER!
	JMP*	LOWER
	TAD	(101+32+40 /RESTORE THE AC AND SHIFT TO LOWER CASE
	DAC*	CHAR
	JMP*	LOWER	/RETURN
/
CONTRL	DAC	SHIFT
	JMP*	LOWER
/
SHIFT	-1
	.END
[\].
NEWPAGSRC
C  NEWPAG SRC					NEWPAG SRC
C  21 FEB 74					21 FEB 74
C............................................................
	SUBROUTINE NEWPAG
C
C  PURPOSE:
C    NEWPAGE IS THE PAGE FLIPPING ROUTINE FOR THE SPEC PRINTER
C    IT PERFORMS THE FOLLOWING TASKS*
C    1.  WRITES THE JOB LINE AT THE BOTTOM OF THE PAGE
C    2.    FLIPS TO AND NI;UMBERS THE NEXT PAGE WITH THE FORMULA
C	<PAGTAG> = <DIVTAG><SECTAG><-><LJI PAGNUM>
C    3.  SKIPS TWO LINES AND WRITES THE ARTICLE NUMBER COMPOSED AS
C	<PREFIX> = <DIVTAG><SECTAG><.><ARTTAG>
C
	IMPLICIT INTEGER (A-Z)
C	******** ******* *****
C
	DIMENSION PREFIX(85)
C
	COMMON  /NUMBRS/
	1   DIVNUM,SECNUM,ARTNUM,PARNUM,SUBNUM,SB2NUM,SB3NUM,SB4NUM,
	1   DIVTAG(5),SECTAG(5),ARTTAG(5),TEMTAG(5)
	COMMON /PAGES/ PAGNUM,PAGTAG(5),LINNUM,JOBID(85),PAGESZ
	COMMON /SLOTS/ IDK1,IDK2,LTA,ICD,LPS
C
	DATA FF,DASH,CR /12,45,13/,CC2,PERIOD /17,46/
	DATA LEFT /70/ ,MARGIN /7/
C.....................................................
	CALL RESET(PREFIX,85)
	PREFIX(3) = CR
C 1. PLACE THE JOB NAME AT THE BOTTOM OF THE SHEET
	JSKIP = PAGESZ - LINNUM
10	IF (JSKIP.LE.0) GO TO 20
	CALL WRITEI(LPS,PREFIX)
	JSKIP = JSKIP - 1
	GO TO 10
20	CONTINUE
	CALL WRITEI(LPS,JOBID)
C
C 2. WRITE THE PAGE NUMBER AT THE TOP
	CALL RESET(PREFIX,85)
	PAGNUM = PAGNUM + 1
	CALL LJI(PAGNUM,PAGTAG,3)
	PREFIX( 1) = FF
	PREFIX(LEFT+1) = DIVTAG(1)
	PREFIX(LEFT+2) = DIVTAG(2)
	PREFIX(LEFT+3) = SECTAG(1)
	PREFIX(LEFT+4) = DASH
	PREFIX(LEFT+5) = PAGTAG(1)
	PREFIX(LEFT+6) = PAGTAG(2)
	PREFIX(LEFT+7) = PAGTAG(3)
	PREFIX(LEFT+8) = CR
	CALL WRITEI(LPS,PREFIX)
	LINNUM = 1
C
C 3. WRITE THE ARTICLE NUMBER
	CALL RESET(PREFIX,85)
	PREFIX(1) = CC2
	PREFIX(MARGIN+1) = DIVTAG(1)
	PREFIX(MARGIN+2) = DIVTAG(2)
	PREFIX(MARGIN+3) = SECTAG(1)
	PREFIX(MARGIN+4) = PERIOD
	PREFIX(MARGIN+5) = ARTTAG(1)
	PREFIX(MARGIN+6) = ARTTAG(2)
	PREFIX(MARGIN+7) = CR
	CALL WRITEI(LPS,PREFIX)
 	LINNUM = LINNUM + 2
C
	RETURN
	END
[\].
POPUP@SRC
        .TITLE  POPUP(LINE)
        .GLOBL  POPUP,.DA
/  DEFINE MAXIMUM SIZE OF LINE
        .DEC
SIZE=85
        .OCT
/  POPUP CODE
POPUP   0               /ENTRY POINT
        JMS*    .DA
        JMP     .+2
LINE    0
        LAC*    LINE    /GET ADDR OF FIRST WORD OF LINE
        DAC     LINE
        LAW     -SIZE   /SETUP LIMIT COUNTER
        DAC     #C
        LAC     LINE    /GET ADDR LINE(1)
        TAD     (-1
        DAC*    (10     /USE FIRST A.I.R. FOR FETCH
        DAC*    (11     /USE SECOND A.I.R. FOR PUT
        LAC*    10      /GET FIRST CHARACTER FOR USER
        DAC     #T      /SAVE IT
        SAD     (15     /RETURN IF CARRIAGE RETURN
        JMP*    POPUP
        ISZ     C       /INCREMENT THE COUNTER
PL1     LAC*    10      /GET LINE(J+1)
        DAC*    11      /PUT IN LINE(J)
        SAD     (15     /CHECK FO R CR
        JMP     PL2
        ISZ     C       /INCREMENT COUNTER
        JMP     PL1     /LOOP
PL2     LAC     T       /PUT T IN AC FOR USER
        JMP*    POPUP
        .END
[\].
PUTL@@SRC
C  PUTL  SRC					PUTL  SRC
C  21 FEB 74						21 FEB 74
C....................................................................
	SUBROUTINE PUTL
C
C  PUTL SUPERVISES THE PRINTING OF THE OUTPUT LINE (LINEX)
C    1. THE CR AT THE END OF THE LINE IS INSERTED
C    2. A CHECK IS MADE TO SEE IF THE LINE WILL FIT ON THE PAGE
C    3. THE LINE IS PACKED AND WRITTEN ON THE OUTPUT DECICE
C  IF THE LINE WILL NOT FIT ON THE PAGE, THE APPROPRIATE PAGING
C  TASKS ARE PERFORMED BEFOR THE CURRENT LINE IS OUTPUT
C    1. A PAGE IS FLIPPED AND NUMBERED
C    2. THE OUTPUT LINE IS WRITTEN
C
C  DECLARATIONS:
	IMPLICIT INTEGER (A-Z)
C	******** ******* *****
C
	LOGICAL NOTES
C
	COMMON /OUTS/ LINEX(85),LAST,LSKIP,NOTES
	COMMON /PAGES/ PAGNUM,PAGTAG(5),LINNUM,JOBID(85),PAGESZ
	COMMON /SLOTS/ IDK1,IDK2,LTA,ICD,LPS
C
	DATA PERIOD,DASH,CR,CC2,CC3 /46,45,13,17,18/
	DATA FF,LF,BLANK /12,10,32/
C...............
C  TERMINATE THE LINE WITH A CARRIAGE CONTROL CHARACTER
10	IF (LAST.LE.0) RETURN
	LAST = LAST + 1
	LINEX(LAST) = CR
C  WILL THIS LINE FIT ON THE CURRENT PAGE?
	IF (LINEX(1).EQ.BLANK) LINEX(1) = LSKIP
	IF (NOTES) LINEX(1) = LF
C  DETERMINE HOW MANY LINES WILL BE REQUIRED
	LINC = 1
	IF (LINEX(1).EQ.CC2) LINC = 2
	IF (LINEX(1).EQ.CC3) LINC = 3
	IF ((LINNUM+LINC).LE.PAGESZ) GO TO 100
C...............
C  FORCE A NEW PAGE
	CALL NEWPAG
C  FORCE A DOUBLE SPACING FOR THE NEXT LINE
	LINEX(1) = CC2
	LINC = 2
C...............
100     CONTINUE
	CALL WRITEI(LPS,LINEX)
	LINNUM = LINNUM + LINC
	CALL RESET(LINEX,85)
	LAST = 0
	RETURN
	END
[\].
PUTW@@SRC
C  PUTW  SRC					PUTW  SRC
C  11 NOV 1973					11 NOV 1973
C.................................................................
        SUBROUTINE PUTW(LINE,N)
C
C  PURPOSE
C    "PUTW" PLACES THE WORD IN THE USER'S LINE "LINE" INTO THE
C    OUTPUT BUFFER LINE "LINEX" AFTER FIRST CHECKING TO SEE THAT
C    IT WILL FIT (IE. LAST+N<LINESZ).  IF THE WORD WON'T FIT, IT
C    WRITES THE CURRENT LINE BUFFER USING "PUTL" AND THEN BEGINS
C    A NEW BUFFER INTO WHICH IT WILL PUT THE USER'S WORD.
C
C  DECLARATION SECTION
	LOGICAL FIRST,NOTES
	INTEGER LINE(85),STAR
        INTEGER DIVNUM,SECNUM,ARTNUM,PARNUM,SUBNUM,SB2NUM,SB3NUM,SB4NUM,
	1   DIVTAG(5),SECTAG(5),ARTTAG(5),TEMTAG(5)
        COMMON  /NUMBRS/
	1   DIVNUM,SECNUM,ARTNUM,PARNUM,SUBNUM,SB2NUM,SB3NUM,SB4NUM,
	1   DIVTAG,SECTAG,ARTTAG,TEMTAG
        COMMON /OUTS/ LINEX(85),LAST,LSKIP,NOTES
C
        DATA MARGIN,STAR /7,42/
        DATA FIRST /.TRUE./
        DATA LINESZ /80/
C...............
C  INITIALIZE THE LINE COUNTER
C  CHECK TO SEE IF THIS WORD WILL FIT ON THE CURRENT LINE
        IF ((LAST+N).GT.LINESZ) GO TO 20
C       ........
1       CONTINUE
C  PLACE THIS WORD INTO THE OUTPUT LINE (LINEX)
        DO 10  J=1,N
        LAST = LAST + 1
        LINEX(LAST) = LINE(J)
10      CONTINUE
        RETURN
C...............
20      CONTINUE
C  THE CURRENT LINE IS FILLED; DUMP IT AND CONTINUE.
        CALL PUTL
        CALL RESET(LINEX,85)
        LAST = MARGIN+ 11
        IF (SUBNUM.GT.0) LAST = MARGIN + 11
        IF (SB2NUM.GT.0) LAST = MARGIN + 16
        IF (SB3NUM.GT.0) LAST = MARGIN + 21
        IF (SB4NUM.GT.0) LAST = MARGIN + 26
        IF (.NOT.NOTES) GO TO 1
	LAST = MARGIN + 11
	DO 30  J=1,6
	IN = MARGIN + J
	LINEX(IN) = STAR
30	CONTINUE
	GO TO 1
C...............
        END
[\].
READI@001
	.TITLE	READI(UNIT,LINE)		17 FEB 1974
	.GLOBL	READI,.DA
/ DEFINE .DAT CONSTANTS
SLOT=0		/DUMMY SLOT NUMBER
MODE=2		/IOPS ASCII MODE
BUFSIZ=44	/DECIMAL 36
/...............
READI	0
	JMS*	.DA
	JMP	.+2+1
UNIT	0
LINE	0
	LAC*	LINE
	DAC	LINE	/NOW POINTS TO THE FIRST WORD OF THE ARRAY
/  MODIFY I-O MACROS FOR VARIOABLE SLOT NUMBERS
	LAC*	UNIT	/GET UNIT N0.
	AND	(777	/MASK IT FOR CAL SEQ
	DAC	WAIT
	XOR	(MODE*1000 /SET MODE BITS
	DAC	READ
/
	LAC	(BUFFER-1	/INITIALIZE AIR FOR BUFFER CLEARING
	DAC*	(10
	LAW	-BUFSIZ
	DAC	C.1#
R.1	DZM*	10	/LOOP TO ZERO BUFFER
	ISZ	C.1
	JMP	R.1
/READ THE NEXT LINE FROM THE FILE
	NOP
READ	.READ	SLOT,MODE,BUFFER,36
WAIT	.WAIT	SLOT
/ UNPACK AND SEND LINE BACK TO THE USER
	LAW	-BUFSIZ+2
	DAC	C.1
	LAC	(BUFFER-1
	DAC*	(10
	LAC	LINE
	TAD	(-1
	DAC*	(11
	LAC*	10	//GET HEADER WORD 0
	DAC	HW0#
	AND	(7	/MASK OUT ENDO OF FILE FLAG AND PASS TO USER
	DAC*	11
	LAC	HW0	/GET HEADER FOR WORD COUNT
	AND	(377000
/	SWHA
	DAC*	11
	LAC	HW0	/NOW CHECK THE EOF FLAG HERE
	AND	(7
	SAD	(5
	JMP*	READI	/RETURN IF EOF INDICATOR ON
	CLL
	LAC*	10	/SKIP OVER THE HW1
R.2	LAW	-5	/SET UP 5 CHARACTER COUNTER LOOP
	DAC	C.2#
	LAC*	10	/GET FIRST HALF OF ASCII PAIR
	DAC	T#
	LAC*	10	/GET SECONF HALF OF ASCII PAIR
	LMQ
	LAC	T
R.3	AND	(774000 /MASK THE LEFT MOST CHARACTER
	SWHA	   /SWAP HALVES
	RTR		/CONVERT TO A GOOD INTEGER
	DAC*	11	/PACK INTO THE USERS BUFFER
	SAD	(15	/WAS THIS THE END OF THE LINE?
	JMP	EOL
	LAC	T	/RESTORE AC TO ORIGINAL BIT PATTERN
	LLS	7	/SHIFT NEXT CHARACTER INTO POSITION
	DAC	T	/SHAVE THE AC
	ISZ	C.2	/INCREMENT THE COUNTER
	JMP	R.3
	ISZ	C.1	/INCREMENT THE BUFFER LIMIT REGISTER
	JMP	R.2
EOL	JMP*	READI
BUFFER	.BLOCK	BUFSIZ
	.END
[\].
RESET@SRC
        .TITLE  RESET(LINE,K)
        .GLOBL  RESET,.DA
/  THIS PROGRAM PLACES BLANKS IN THE FIRST K PLACES OF LINE
RESET   0
        JMS*    .DA
        JMP     .+3
LINE    0
K       0
        LAC*    K
        CMA
        DAC     K
        LAC*    LINE
        TAD     (-1
        DAC*    (10
        LAC     (40
RL1     DAC*    10
        ISZ     K
        JMP     RL1
        JMP*    RESET
        .END
[\].
RJI@@@SRC
C  RJI    SRC					RJI    SRC
C  11 NOV 1973					11 NOV 1973
C............................................................
C
	SUBROUTINE RJI(N,LINE,WIDTH,FILL)
C
C  PURPOSE
C  THIS SUBROUTINE CONVERTS AN INTEGER (N) TO ASCII (LINE) IN A FIELD
C  OF WIDTH (WIDTH) WITH LEADING ZERO'S IF (FILL=0) OTHERWISE WITH
C  LEADING BLANKS
C
C  DECLARATION SECTION:
	INTEGER WIDTH,ZERO,FILL,BLANK,STAR,LINE(10),INT(10)
C
	DATA BLANK,STAR,ZERO /32,42,48/
	DATA INT /48,49,50,51,52,53,54,55,56,57/
C........................................................
C  FILL THE LINE WITH THE APPROPRIATE CHARACTERS
	INT(1) = BLANK
	IF (FILL.EQ.0) INT(1) = ZERO
	JUNK = INT(1)
	DO 10  J=1,WIDTH
	LINE(J) = JUNK
10      CONTINUE
C       ........
C  CHECK TO SEE IF THE INTEGER WILL FIT ON THE LINE
	IW = 1
	IT = N
	K = 1
	DO 20  J=1,WIDTH
	IW = 10*IW
20      CONTINUE
	IF (N.LT.IW) GO TO 30
	LINE(1) = STAR
	IW = IW/100
	IF (IW.EQ.0) RETURN
	IT = MOD(IT,IW)
	K = 2
C       ........
C  FILL OUT THE LINE WITH THE CONVERTED INTEGER
30      CONTINUE
	DO 40  J=K,WIDTH
	IW = IW/10
	IN = IT/IW
	IF (IN.NE.0) INT(1) = ZERO
	LINE(J) = INT(IN+1)
	IT = IT - IN*IW
40      CONTINUE
C  CONVERTION COMPLETED
	RETURN
	END
[\].
SETUIC001
	.TITLE SETUIC VTVIEW
	.GLOBL SETUIC
/  UIC'S FOR SPECS
SETUIC	0
	.USER 1,SPC
	.USER 2,SPC
	.USER 3,SPC
	.USER 5,SPC
	JMP*	SETUIC
	.END
[\].
SPECS@SRC
C  SPECS SRC						SPECS SRC
C  5 MARCH 74						5 MARCH 74
C
C
C			PROGRAM SPECS
C			------- -----
C			  SYSTEM 76
C			_____________
C
C  	SPECIFICATION PRINTING PROGRAM:
C  THIS PROGRAM SUPERVISES THE PRODUCTION OF THE PRINTED OUTPUT FOR
C  PD&S PROJECT SPECIFICATIONS.
C
C  NOTE:  PAGE SIZE
C    PAGE SIZE FOR THE BOSTON OFFICE IS 65 PRINTED LINES/PAGE.
C      THIS GIVES 12 BLANK LINES BETWEEN PAGES SINCE LPC.
C      NORMALLY PRINTS 69 AND GIVES 8 BLANKS.
C
C  PAGE SIZE FOR THE SYSTEM 76 IS 54 PRINTED LINES PER PAGE
C      USING THE LVA HANDLER WITH FORM FEEDS.
C  DAT SLOT USAGE
C	1 = IDK1 :  CONTAINS THE SOURCE SPEC (EXT=SPC)
C	2 = IDK2 =  COUNTAINS THE EDITED OUTPUT (EXT=SPC)
C	4 = LTA   :  USED FOR USER MESSAGES
C	5 = ICD	 :  CONTAINS THE CARDS DECK TO DRIVE THE EDITOR
C	6 = LPS   :  CONTAINS THE FORMATTED SPECS (EXT=LST)
C
C  CHAIN STRUCTURE
C
C	XCT FILE NAME = SPECS
C
C	RESIDENT CODE = SPECS
C
C	LINKS & STRUT = NONE, THERE ISN'T ANY
C
C	CORE REQ'D    =
C
C
C
C  DECLARATION SECTION
C
C  TYPES:
	IMPLICIT INTEGER (A-Z)
C	******** ******* *****
C
	LOGICAL WORK,YES
C
	REAL SIGNET(4)
C
C  COMMON BLOCKS:
	COMMON  /NUMBRS/
	1   DIVNUM,SECNUM,ARTNUM,PARNUM,SUBNUM,SB2NUM,SB3NUM,SB4NUM,
	1   DIVTAG(5),SECTAG(5),ARTTAG(5),TEMTAG(5)
	COMMON /PAGES/ PAGNUM,PAGTAG(5),LINNUM,JOBID(85),PAGESZ
	COMMON /SLOTS/ IDK1,IDK2,LTA,ICD,LPS
	COMMON /FORMS/ WORK
	COMMON /OUTS/ LINEX(85),LIWORD,LSKIP,NOTES
C
C  DATA DECLARATION:
C    SIGNATURE
	DATA SIGNET /5HSPECS,5H - VE,5HRSION,5H 2A3 /
C  ..............................................................
C
C  SETUP UIC CONVENTION
C**NO SETUIC FOR GNC IN TORONTO!
C
C  DEFINE PAGE SIZE
	PAGESZ = 54
C  DAT SLOTS
	IDK1 = 1
	IDK2 = 2
	LTA = 4
	ICD = 5
	LPS = 6
C  SIGN IN
	CALL LOGON(SIGNET)
C
C
C  OBTAIN DIRECTIONS
100	CONTINUE
	WRITE (LTA,102)
102	FORMAT ("1  SPECS - SPECIFICATIONS PRODUCTION PROGRAM")
C
C  EDIT?
110	CONTINUE
	WRITE (LTA,112)
112	FORMAT ("0  DO YOU WANT TO EDIT FROM CARDS?  (Y OR N)")
	IF (.NOT.YES(LTA)) GO TO 120
	CALL EDITCD
C
C
C  NUMBERED LISTING?
120	CONTINUE
	WRITE (LTA,122)
122	FORMAT ("0  DO YOU WANT TO LIST A SPC FILE WITH LINE NUMBERS?")
	IF (.NOT.YES(LTA)) GO TO 130
	CALL LISTN
C
C  FORMATTED LISTINGS?
130	CONTINUE
	WRITE (LTA,132)
132	FORMAT ("0  DO YOU WANT TO PRODUCE A WORKING SPEC?")
	IF (.NOT.YES(LTA)) GO TO  140
	WORK = .TRUE.
	CALL SPRINT
	GO TO 190
C
C  FINAL SPEC?
140	CONTINUE
	WRITE (LTA,142)
142	FORMAT ("0  DO YOU WANT TO PRODUCE A FINAL COPY OF THE SPEC?")
	IF (.NOT.YES(LTA)) GO TO 150
	WORK = .FALSE.
	CALL SPRINT
C
150	CONTINUE
C  DONE?
190	CONTINUE
	WRITE (LTA,192) 
192	FORMAT ("0  DO YOU HAVE ANY MORE SPEC WORK TO DO?")
	IF (YES(LTA)) GO TO 100
C
C  THATS ALL!
	STOP
	END
[\].
SPRINTSRC
C  SPRINT SRC					SPRINT SRC
C  24 FEB 1974						24 FEB 74
C
	                        SUBROUTINE SPRINT
C  ...........................................................
C
C  	SPECIFICATION PRINTING PROGRAM:
C  THIS PROGRAM SUPERVISES THE PRODUCTION OF THE PRINTED OUTPUT FOR
C  PD&S PROJECT SPECIFICATIONS.
C
C  NOTE:  PAGE SIZE
C    PAGE SIZE FOR THE BOSTON OFFICE IS 65 PRINTED LINES/PAGE.
C      THIS GIVES 12 BLANK LINES BETWEEN PAGES SINCE LPC.
C      NORMALLY PRINTS 69 AND GIVES 8 BLANKS.
C
C  DAT SLOT USAGE
C	1 = IDK1  :  CONTAINS THE SOURCE SPEC (EXT=SPC)
C	4 = LTA   :  USED FOR USER MESSAGES
C	6 = LIST  :  CONTAINS THE FORMATTED SPECS (EXT=LST)
C
C  ............................................................................
C  DECLARATION SECTION
C
C  TYPES:
	INTEGER POPUP
	LOGICAL ISIT,WORK,NOTES,YES
	INTEGER LETR(85),PREFIX(85)
	INTEGER PAGNUM,PAGTAG(5),PAGESZ
	INTEGER CC2,CC3,DASH,PERIOD,CR,LPAREN,RPAREN,BLANK,FF
	INTEGER STAR
	REAL    RFILE(2),WFILE(2),SFILE(2)
	REAL AMONTH,AMO
	REAL EMPTY
	INTEGER DIVNUM,SECNUM,ARTNUM,PARNUM,SUBNUM,SB2NUM,SB3NUM,SB4NUM,
	1   DIVTAG(5),SECTAG(5),ARTTAG(5),TEMTAG(5)
C
C  COMMON BLOCKS:
	COMMON  /NUMBRS/
	1   DIVNUM,SECNUM,ARTNUM,PARNUM,SUBNUM,SB2NUM,SB3NUM,SB4NUM,
	1   DIVTAG,SECTAG,ARTTAG,TEMTAG
	COMMON /PAGES/ PAGNUM,PAGTAG,LINNUM,JOBID(85),PAGESZ
	COMMON /OUTS/ LINEX(85),LIWORD,LSKIP,NOTES
	COMMON /SLOTS/ IDK1,IDK2,LTA,ICD,LPS
	COMMON /FORMS/ WORK
C
C  DATA DECLARATION:
C  1.  NUMERICAL EQUIVALENTS OF LETTERS FOR HEADINGS
	DATA    LS,LE,LC,LT,LI,LO,LN /83,69,67,84,73,79,78/
	DATA    LJ,LB,LA,LM,LE /74,66,65,77,69/
C  2.  KEY WORDS
	DATA EMPTY /5H     /
C  3.  CONSTANTS
	DATA    MARGIN,LWIDTH /7,80/
	DATA     STAR /42/
	DATA    BLANK,DASH,PERIOD,LPAREN,RPAREN  /32,45,46,40,41/
	DATA    CC2,CC3,FF,LFEED,CR /17,18,12,10,13/
C  4.  OUTPUT FILE NAME
	DATA    WFILE(2),RFILE(2) /4H LST,4H SPC/
C  ...........
C  ENTRY POINT
1	CONTINUE
C
C  INITIATE COMMUNICATION WITH USER
C
	WRITE (LTA,9)
 9	FORMAT (1H1,10X," SPECS : SPECIFICATION PRINTING"/)
C  SET UP FOR READING THE MASTER SPEC
	WRITE (LTA,11)
11	FORMAT (/2X,"WHAT IS THE NAME OF THE SPC FILE? ")
20      CONTINUE
C  READ THE FILE NAME (NINE CHARACTTERS)
	READ (LTA,21) RFILE(1)
21      FORMAT (A5)
	WFILE(1) = RFILE(1)
C  IS THE MASTER SPEC ON "INPUT"?
	CALL FSTAT(IDK1,RFILE,ISIT)
	CALL CLOSE(IDK1)
	IF (ISIT) GO TO 30
C
C  "FILE NOT FOUND"
	CALL BEEPER
	WRITE(LTA,22)
22	FORMAT (/2X,"FILE NOT FOUND, PLEASE RETYPE NAME.")
	GO TO 20
C
C  GET THE INITIAL DIVISION NUMBER
30	CONTINUE
	WRITE (LTA,31)
31	FORMAT (/2X,"WHAT IS THE DIVISION NUMBER?")
32	READ (LTA,) FNUM
	DIVNUM = FNUM
C  CHECK FOR A LEGAL DIVISION NUMBER
	IF ((DIVNUM.GE.1).AND.(DIVNUM.LE.16)) GO TO 35
	WRITE (LTA,34)
34	FORMAT (2X,"ILLEGAL DIVISION NUMBER.  PLEASE RETYPE")
	GO TO 32
35	DIVNUM = DIVNUM - 1
C
C  SET UP THE JOB IDENTIFICATION LINE FOR THE BOTTOM OF THE PAGE
40	CONTINUE
C  SET-UP FOR WORKING SPEC OR FINAL SPEC
	IF (WORK) GO TO 47
C
C  FINAL COPY REQUESTED, GET JOB NAME.
45	CONTINUE
	WRITE (LTA,46)
46	FORMAT (/2X,"WHAT IS THE JOB NAME?")
	CALL READI(LTA,JOBID)
	LSKIP = LFEED
	GO TO 50
C
C  GENERATE A WORK SHEET LINE
47	CONTINUE
	JOBID(1) = LJ
	JOBID(2) = LO
	JOBID(3) = LB
	JOBID(4) = BLANK
	JOBID(5) = LN
	JOBID(6) = LA
	JOBID(7) = LM
	JOBID(8) = LE
	JOBID(9) = JOBID(10) = BLANK
	DO 48  J=11,20
	JOBID(J) = PERIOD
48	CONTINUE
	JOBID(21) = CR
	LSKIP = CC2
C
C  RIGHT JUSTIFY THE JOBID
50	CALL RESET(PREFIX,85)
	DO 51  J=1,85
	IF (JOBID(J).EQ.CR) GO TO 52
51	CONTINUE
	J = 85
52	JMAX = J
	LMIN = LWIDTH - JMAX
	DO 53  J=1,JMAX
	L = LMIN + J
	PREFIX(L) = JOBID(J)
53	CONTINUE
	DO 54  J=1,85
	JOBID(J) = PREFIX(J)
54	CONTINUE
	JOBID(1) = CC3
C  TELL THE USER THAT THE JOB IS NOW BEING PROCESSED
60	CONTINUE
	WRITE (LTA,61)
61	FORMAT (/2X,"THE SPEC IS NOW BEING PRODUCED.  PLEASE WAIT.")
C
C
C  INITIALIZE THE FILES AND CONTINUE
C
	CALL INIT(IDK1,0)
	CALL SEEK(IDK1,RFILE)
C
	CALL INIT(LPS,1)
	CALL ENTER(LPS,WFILE)
C
	LINNUM = 0
	LIWORD = 0
	CALL RESET(LINEX,85)
	GO TO 210
C  ...........
C  DOCUMENT PRODUCTION SECTION
100	CONTINUE
	CALL GETW(LETR,N)
	IF (N.LE.0)     GO TO 110
	CALL PUTW(LETR,N)
	GO TO 100
C  ...........
110	CONTINUE
C  COMMAND DECYPHERIZATION SECTION
	NOTES = .FALSE.
C  ........
C  FIRST DUMP THE CURRENT OUTPUT LINE
	CALL PUTL
	K = -N
	IF (K.EQ.999) GO TO 900
	K = LEVEL(K)
	IF (K.LE.10) GO TO (210,220,230,240,250,260,270,280,290,300),K
C  ........
C  IF WE FALL THROUGH TO THE NEXT STATEMENT, THERE HAS BEEN A FATAL
C  ERROR IN THE INTERPRETATION OF A COMMAND, OR THERE HAS BEEN AN
C  ILLEGAL COMMAND
C  ........
	CALL BEEPER
	WRITE (LTA,120)
120	FORMAT (//
	1 82("*")//
	2 "           UNRECOGNIZED CONTROL CHARACTER ENCOUNTERED."/
	3 "           PLEASE CHECK YOUR INPUT FILE FOR THE TEXT"/
	4 "           WHICH FOLLOWS THE LAST PRINTED LINE."//
	5 82("*")/)
	GO TO 900
C
C
C  TITLE PROCESSINC SECTIONS
C
210     CONTINUE
C  DIVISION PROCESSING
	DIVNUM = DIVNUM + 1
	SECNUM = ARTNUM = PARNUM = SUBNUM = SB2UM = SB3NUM = SB4NUM = 0
	CALL RJI(DIVNUM,DIVTAG,2,-1)
	CALL SYSDAY(IM,ID,IY)
	AMO = AMONTH(IM)
	DO 213 J=1,20
	WRITE (LPS,212) RFILE,ID,AMO,IY
212	FORMAT (//1X,20(1H*),5X,A4,A5" - ",I2,1X,A4,I2,5X,20(1H*))
213	CONTINUE
C
	WRITE (LPS,214)
214	FORMAT (1H1)
	GO TO 100
C  ........
220     CONTINUE
C  SECTION PROCESSING
	SECNUM = SECNUM + 1
	ARTNUM = PARNUM = SUBNUM =  SB2NUM = SB3NUM = SB4NUM = 0
	SECTAG(1) = LETTER(SECNUM)
	PAGNUM = 0
	CALL NEWPAG
	CALL RESET(PREFIX,MARGIN+25)
C  FIRST FORM THE DIVISION-SECTION NUMBER AND LEFT JUSTIFY IT
	PREFIX(MARGIN+20) = DIVTAG(1)
	PREFIX(MARGIN+21) = DIVTAG(2)
	PREFIX(MARGIN+22) = SECTAG(1)
	PREFIX(MARGIN+23) = BLANK
	PREFIX(MARGIN+24) = DASH
	PREFIX(MARGIN+25) = BLANK
	IF (DIVNUM.LT.10) JUNK = POPUP(PREFIX)
C  NOW FOR THE FIRST PART OF THE LINE
	PREFIX(1) = CC3
	PREFIX(MARGIN+12) = LS
	PREFIX(MARGIN+13) = LE
	PREFIX(MARGIN+14) = LC
	PREFIX(MARGIN+15) = LT
	PREFIX(MARGIN+16) = LI
	PREFIX(MARGIN+17) = LO
	PREFIX(MARGIN+18) = LN
	LENGTH = 25
	IF (DIVNUM.LT.10) LENGTH = 24
	CALL PUTW(PREFIX,MARGIN+LENGTH)
C  GET THE REMAINDER OF THE LINE WHICH IS TITLE INFORMATION
	GO TO 100
C  ........
230     CONTINUE
C  ARTICLE PROCESSING
	ARTNUM = ARTNUM + 1
	PARNUM = SUBNUM = SB2NUM = SB3NUM = SB4NUM = 0
	CALL RJI(ARTNUM,ARTTAG,2,0)
	CALL RESET(PREFIX,MARGIN+11)
	PREFIX(1) = CC2
	IF (ARTNUM.EQ.1) PREFIX(1) = CC3
	PREFIX(MARGIN+1) = DIVTAG(1)
	PREFIX(MARGIN+2) = DIVTAG(2)
	PREFIX(MARGIN+3) = SECTAG(1)
	PREFIX(MARGIN+4) = PERIOD
	PREFIX(MARGIN+5) = ARTTAG(1)
	PREFIX(MARGIN+6) = ARTTAG(2)
	CALL PUTW(PREFIX,MARGIN+11)
	GO TO 100
C  ........
C  PARAGRAPH PROCESSING
240     CONTINUE
	CALL RESET(PREFIX,MARGIN+11)
	PARNUM = PARNUM + 1
	SUBNUM = SB2NUM = SB3NUM = SB4NUM = 0
	TEMTAG(1) = LETTER(PARNUM)
	PREFIX(1) = CC2
	PREFIX(MARGIN+7) = TEMTAG(1)
	PREFIX(MARGIN+8) = PERIOD
	CALL PUTW(PREFIX,MARGIN+11)
	GO TO 100
C  ........
C  SUBPARAGRAPH PROCESSING
250     CONTINUE
	CALL RESET(PREFIX,MARGIN+11)
	SUBNUM = SUBNUM + 1
	SB2NUM = SB3NUM = SB4NUM = 0
	PREFIX(1) = CC2
	CALL RJI(SUBNUM,TEMTAG,2,-1)
	PREFIX(MARGIN+7) = TEMTAG(1)
	PREFIX(MARGIN+8) = TEMTAG(2)
	PREFIX(MARGIN+9) = PERIOD
	CALL PUTW(PREFIX,MARGIN+11)
	GO TO 100
C  ........
C  SUB-SUBPARAGRAPH PROCESSING
260     CONTINUE
	CALL RESET(PREFIX,MARGIN+16)
	SB2NUM = SB2NUM + 1
	SB3NUM = SB4NUM = 0
	PREFIX(1) = CC2
	PREFIX(MARGIN+12) = LETTER(-SB2NUM)
	PREFIX(MARGIN+13) = PERIOD
	CALL PUTW(PREFIX,MARGIN+16)
	GO TO 100
C	........
C  SUB-SUB-SUBPARAGRAPH PROCESSING
270     CONTINUE
	CALL RESET(PREFIX,MARGIN+21)
	SB3NUM = SB3NUM + 1
	SB4NUM = 0
	CALL RJI(SB3NUM,TEMTAG,1,-1)
	PREFIX(1) = CC2
	PREFIX(MARGIN+16) = LPAREN
	PREFIX(MARGIN+17) = TEMTAG(1)
	PREFIX(MARGIN+18) = RPAREN
	CALL PUTW(PREFIX,MARGIN+21)
	GO TO 100
C	........
C  SUB-SUB-SUB-SUBPARAGRAPH PROCESSING
280     CONTINUE
	CALL RESET(PREFIX,MARGIN+26)
	SB4NUM = SB4NUM + 1
	PREFIX(MARGIN+21) = LPAREN
	PREFIX(MARGIN+22) = LETTER(-SB4NUM)
	PREFIX(MARGIN+23) = RPAREN
	CALL PUTW(PREFIX,MARGIN+26)
	GO TO 100
C  .........
C      UNSHUFFLED TEXT SECTION
290     CONTINUE
	CALL RESET(PREFIX,MARGIN+11)
	CALL PUTW(PREFIX,MARGIN+11)
	GO TO 100
C  ........
C  NON-PRINTING TEXT PROCESSING
300	CONTINUE
	IF (.NOT.WORK) GO TO 302
	NOTES = .TRUE.
	CALL RESET(PREFIX,MARGIN+11)
	DO 301  J=1,6
	IN = MARGIN + J
	PREFIX(IN) = STAR
301	CONTINUE
	CALL PUTW(PREFIX,MARGIN+11)
302	CALL GETW(LETR,N)
	IF(N.LT.0) GO TO 110
	IF (WORK) CALL PUTW(LETR,N)
	GO TO 302
C  ........
C  ........
C  END OF FILE PROCESSING
C  ...........
C  FINALIZATION AND PRINTING SECTION
900	CONTINUE
	CALL NEWPAG
	CALL CLOSE(IDK1)
	CALL CLOSE(LPS)
C
C  ASK FOR RESTART
	CALL BEEPER
	WRITE (LTA,905) DIVNUM
905	FORMAT (//2X,"DIVISION",I3," PROCESSING FINISHED?"
	1       //2X,"DO YOU WISH TO PROCESS ANOTHER DIVISION?" )
	IF (YES(LTA)) GO TO 1
C
C
	END
[\].
SRCSPCSRC
C  CCC   SRC					CCC   SRC
C  10 NOV 73
C...............................................................
C
C  PURPOSE:
C	TO CHANGE CONTROL CHARACTERS IN THE SPEC DATA BASE FILES
C..................................................................
	LOGICAL ISIT
C
	DIMENSION LINE(85),MINE(85),FIN(2),FOUT(2)
C
	EQUIVALENCE (MINE(1),LINE(3)),(KEY,MINE(1))
	EQUIVALENCE (LAST,LINE(1))
C
	DATA BLANK,SRC /5H     ,4H SRC/
C...............................................................
	INPUT = 1
	IOUT  = 2
	IVT   = 4
C
C  GET THE FILE NAMES
1	WRITE (IVT,5)
5	FORMAT ("1CONTROL CHARACTER CONVERTOR  (VERSION 10 NOV 73)")
C
10	CONTINUE
C
	WRITE (IVT,15)
15	FORMAT (" WHAT IS THE INPUT FILE NAME?")
	READ(IVT,16) REPLY,EXT
16	FORMAT (A5,
A4)
	IF (REPLY.EQ.BLANK) GO TO 10
	IF (EXT.EQ.BLANK) EXT = SRC
	FIN(1) = REPLY
	FIN(2) = EXT
	CALL FSTAT(INPUT,FIN,ISIT)
	CALL CLOSE(INPUT)
	IF (ISIT) GO TO 20
	GO TO 10
C
20	CONTINUE
	WRITE (IVT,22)
22	FORMAT (" WHAT IS THE OUTPUT FILE NAME?")
	READ (IVT,16) REPLY, EXT
	FOUT(1) = REPLY
	FOUT(2) = EXT
	IF (REPLY.EQ.BLANK) FOUT(1) = FIN(1)
	IF (EXT  .EQ.BLANK) FOUT(2) = SRC
C
100	CONTINUE
	CALL SEEK(INPUT,FIN)
	CALL ENTER(IOUT,FOUT)
110	CALL READIN(LINE)
	IF (LAST.EQ.  5) GO TO 200
	IF (KEY .EQ.126) KEY =  48
	IF (KEY. EQ.124) KEY =  49
	IF (KEY .EQ. 60) KEY =  50
	IF (KEY .EQ. 61) KEY =  51
	IF (KEY .EQ. 62) KEY =  52
	CALL WRITEL(MINE)
	GO TO 110
C
200	CONTINUE
	CALL CLOSE(INPUT)
	CALL CLOSE(IOUT)
	STOP
	END
[\].
SYSDAY001
	.TITLE SYSDAY
/
/  SUBROUTINE SYSDAY(MONTH,IDAY,IYEAR)
/
/  DEFINE YEAR OFFSET
	.DEC
OFFSET=70
	.OCT
/
	.GLOBL SYSDAY,.DA
.SCOM=100
/
SYSDAY	0
	JMS*	.DA
	JMP	.+1+3
MONTH	0
DAY	0
YEAR	0
	LAC*	(.SCOM+47
	DAC	SAVE#
	AND	(77	/GET YEAR
	TAD	(OFFSET
	DAC*	YEAR	/PASS IT BACK
	LAC	SAVE
	LRS 6
	AND	(77
	DAC*	DAY
	LAC	SAVE
	LRS 14
	AND	(77
	DAC*	MONTH
	JMP*	SYSDAY
	.END
[\].
TRIM@@SRC
C  TRIM SRC						TRIM SRC
C  19 FEB 74						19 FEB 74
C
                        SUBROUTINE TRIM(LINE)
C
C  TRIMS THE "LINE" SO THAT THE LINE ENDS WITH A "CR" AFTER
C  THE LAST NON-BLANK CHARACTER IN THE LINE
C
C  *****  NOTE: WE USE A DECREMENTED DO LOOP!    *****
C
C
	IMPLICIT INTEGER (A-Z)
C	******** ******* *****
C
	DIMENSION LINE(85)
C  ASCII CONTROL CHARACTERS
	DATA BLANK,CR,EOF /#040,#015,#005/
C
C.................................................................
C  REPLACE TERMINAL BLANKS WITH "CR" USING BACKWARDS DO LOOP
	LINE(81) = CR
	DO 100  J=9,80
	I = 89 - J
	IF (LINE(I).NE.BLANK) RETURN
	LINE(I) = CR
100	CONTINUE
	RETURN
	END
[\].
WRITEI001
	.TITLE	WRITEI(UNIT,LINE)		17 FEB 1974
	.GLOBL	WRITEI,.DA
/DEFINE THE .DAT CONSTANTS
MODE=2		/IOPS ASCII MODE
SLOT=0		/DUMMY SLOT NUMBER
BUFSIZ=44
/...............
WRITEI	0		/ENTRY POINT
	JMS*	.DA
	JMP	.+2+1
UNIT	0
LINE	0
	LAC*	LINE	/GET ADDRESS OF FIRST WORD OF ARRAY
	DAC	LINE
/
/  MODIFY I/O STATEMENTS TO GIVE VARIABLE UNIT ADDRESSING
	LAC*	UNIT	/GET OUTPUT UNIT
	AND	(777	/MAKE SURE IT IS PROPERLY MASKED
	DAC	WAIT	/PUT IN IN FIRST WORD OF .WAIT
	XOR	(MODE*1000 /ADD MODE INDICATOR
	DAC	WRITE
/
WAIT	.WAIT	SLOT
/ZERO OUT THE BUFFER
	LAW	-BUFSIZ
	DAC	C.1#
	LAC	(BUFFER-1
	DAC*	(10	/DEPOSIT ADDRESS IN AIR0
W.1	DZM*	10	/CLEAR BUFFER
	ISZ	C.1
	JMP	W.1
/PREPARE TO TRANSFER USERS DATA TO THE BUFFER
	NOP
	DZM	C.1	/C.1 TO BE USED FOR WORD PAIR COUNTER
	LAC	(BUFFER+1
	DAC*	(10
	LAC	LINE
	TAD	(-1
	DAC*	(11
	CLA!CMA		/SET AC=-1 FOR FLAG
	DAC	DFLAG#	/SET THE LINE COMPLETION FLAG
W.2	LAW	-5	/SET UP THE 5 CHARACTER COUNTER
	DAC	C.2#
	ISZ	C.1	/INCREMENT WORD PAIR COUNTER
	CLA		/CLEAR AC
	LMQ		/CLEAR MQ
	DAC	T#
W.3	LAC*	11	/GET THE NEXT CHARACTER FROM THE USER
	AND	(177	/MASK IT
	SAD	(15	/CHECK FOR AN END OF LINE CHARACTER
	DZM	DFLAG	/SET THE LINE COMPLETED FLAG ON
	XOR	T	/BRING IN WHAT HAS ALREADY BEEN PACKED
	DAC	T	/SAVE THE AC
	LAW	-7	/SETUP THE SHIFT COUNTER FOR 1 CHARACTER
	DAC	S.1
	LAC	T
	JMS	SHIFT	/------- USING A SUBROUTINE
	DAC	T	/SAVE THE AC
	ISZ	C.2	/INCRE,ENT CHARACTER COUNTER
	JMP	W.3
	DAC	T	/SAVE THE AC
	LAW	-14	/SHIFT COUNTER
	DAC	S.1
	LAC	T	/RESTORE THE AC
	JMS	SHIFT
	DAC*	10	/PUT FIRST HALF INTO THE BUFFER
	LACQ		/GET THE SECOND HALF
	DAC*	10	/PUT THE SECOND HALF INTO THE BUFFER
	LAC	DFLAG	/CHECK THE LINE COMPLETION FLAG
	SZA		/=0 MEANS THAT THE BUFFER IS FILLED
	JMP	W.2	/GO TET THE NEXT WORD PAIR.
/ENTER THE CORRECT HEADER DATA AND EMIT A LINE
	ISZ	C.1	/ICREMENT WPC FOR HWP
	LAC	C.1
	SWHA		/MULTIPLY BY 1000
	XOR	(2	/MASK IN MODE BITS
	DAC	BUFFER
	DZM	BUFFER+1
WRITE	.WRITE	SLOT,MODE,BUFFER,36
/RETURN TO CALLING PROGRAM
	JMP*	WRITEI
/SHIFTING ROUTINE
SHIFT	0		/ENTRY-RETURN ADDRESS
S.0	LLSS	1	/SHIFT LEFT CIRCULAR ONCE
	ISZ	S.1	/INCREMENT COUNT
	JMP	S.0
	JMP*	SHIFT	/EXIT FROM SHIFT
S.1	0		/COUNTER
/
BUFFER	.BLOCK	BUFSIZ
	.END
[\].
WRITEL001
	.TITLE	WRITEL(LINE)	4 FEB 1974
	.GLOBL	WRITEL,.DA
/DEFINE THE .DAT CONSTANTS
SLOT=6
IOPS=2
BUFSIZ=44
/...............
WRITEL	0		/ENTRY POINT
	JMS*	.DA
	JMP	.+1+1
LINE	0
	LAC*	LINE
	DAC	LINE	/NOW CONTAINS THE ADDRESS OF THE FIRST WORD
	.WAIT	SLOT
/ZERO OUT THE BUFFER
	LAW	-BUFSIZ
	DAC	C.1#
	LAC	(BUFFER-1
	DAC*	(10	/DEPOSIT ADDRESS IN AIR0
W.1	DZM*	10	/CLEAR BUFFER
	ISZ	C.1
	JMP	W.1
/PREPARE TO TRANSFER USERS DATA TO THE BUFFER
	NOP
	DZM	C.1	/C.1 TO BE USED FOR WORD PAIR COUNTER
	LAC	(BUFFER+1
	DAC*	(10
	LAC	LINE
	TAD	(-1
	DAC*	(11
	CLA!CMA		/SET AC=-1 FOR FLAG
	DAC	DFLAG#	/SET THE LINE COMPLETION FLAG
W.2	LAW	-5	/SET UP THE 5 CHARACTER COUNTER
	DAC	C.2#
	ISZ	C.1	/INCREMENT WORD PAIR COUNTER
	CLA		/CLEAR AC
	LMQ		/CLEAR MQ
	DAC	T#
W.3	LAC*	11	/GET THE NEXT CHARACTER FROM THE USER
	AND	(177	/MASK IT
	SAD	(15	/CHECK FOR AN END OF LINE CHARACTER
	DZM	DFLAG	/SET THE LINE COMPLETED FLAG ON
	XOR	T	/BRING IN WHAT HAS ALREADY BEEN PACKED
	DAC	T	/SAVE THE AC
	LAW	-7	/SETUP THE SHIFT COUNTER FOR 1 CHARACTER
	DAC	S.1
	LAC	T
	JMS	SHIFT	/------- USING A SUBROUTINE
	DAC	T	/SAVE THE AC
	ISZ	C.2	/INCRE,ENT CHARACTER COUNTER
	JMP	W.3
	DAC	T	/SAVE THE AC
	LAW	-14	/SHIFT COUNTER
	DAC	S.1
	LAC	T	/RESTORE THE AC
	JMS	SHIFT
	DAC*	10	/PUT FIRST HALF INTO THE BUFFER
	LACQ		/GET THE SECOND HALF
	DAC*	10	/PUT THE SECOND HALF INTO THE BUFFER
	LAC	DFLAG	/CHECK THE LINE COMPLETION FLAG
	SZA		/=0 MEANS THAT THE BUFFER IS FILLED
	JMP	W.2	/GO TET THE NEXT WORD PAIR.
/ENTER THE CORRECT HEADER DATA AND EMIT A LINE
	ISZ	C.1	/ICREMENT WPC FOR HWP
	LAC	C.1
	SWHA		/MULTIPLY BY 1000
	XOR	(2	/MASK IN MODE BITS
	DAC	BUFFER
	DZM	BUFFER+1
	.WRITE	SLOT,IOPS,BUFFER,36
/RETURN TO CALLING PROGRAM
	JMP*	WRITEL
/SHIFTING ROUTINE
SHIFT	0		/ENTRY-RETURN ADDRESS
S.0	LLSS	1	/SHIFT LEFT CIRCULAR ONCE
	ISZ	S.1	/INCREMENT COUNT
	JMP	S.0
	JMP*	SHIFT	/EXIT FROM SHIFT
S.1	0		/COUNTER
/
BUFFER	.BLOCK	BUFSIZ
	.END
[\].
YES@@@SRC
C  YES SRC						YES SRC
C  25 FEB 74						25 FEB 74
C
C
	                LOGICAL FUNCTION YES(LTA)
C
C  PURPOSE:
C
C    FUNCTION TO RETURN A .TRUE. IF THE USER REPLIES WITH A Y TO
C    A YES NO QUESTION, A .FALSE. IF NO, AND TO MAKE SURE THAT 
C    NOTHING ELSE IS ACCEPTED
C
C
C  ARGUMENTS:
C
C    LTA - DAT SLOT TO READ/WRITE FROM
C
C  .........................................................................
C
10	CONTINUE
	READ (LTA,20) ANS
20	FORMAT (A1)
C  PROTECT AGAINST UNACCEPTABLE ANSWERS
	IF (ANS.NE.1HY .AND. ANS.NE.1HN) GO TO 30
C  RETURN WITH YES SET TO CORRECT VALUE
	YES = ANS.EQ.1HY
	RETURN
C
C  UNACCEPTABLE REPLY
30	CONTINUE
	CALL BEEPER
	WRITE (LTA,40)
40	FORMAT (" PLEASE TYPE YES OR NO")
	GO TO 10
C
	END
[\].