CALL LINE(IMAG,IX)
      GOTO 140
C----I/P SYNCHRONOUS FOR PAGE MODE
161   WRITE(LU,948) 
      GOTO 165
C-----O/P    DEC -LU
220   CALL FLUSH(IMAG,40) 
      CALL CODE 
      WRITE(IMAG,905) 
      LUX=-LUX
      CALL CODE 
      WRITE(OPND,180)LUX
      CALL LINE(IMAG,IX)
      GOTO 140
C----O/P NO         END OF LIST 
900   CALL FLUSH(IMAG,40) 
      CALL CODE 
      WRITE(IMAG,921) 
      CALL LINE(IMAG,IX)
C----TEST FOR SLC USAGE 
      IF(LU.NE.1)GOTO 1100
      WRITE(LU,941) 
1100  IF(RBIN(2HNO,2HYE,LU))GOTO 2000 
C----O/P EXT SLC
      CALL FLUSH(IMAG,40) 
      CALL CODE 
      WRITE(IMAG,927) 
      CALL CODE 
      WRITE(OPND,942) 
      CALL LINE(IMAG,IX)
C----O/P JSB SLC
      CALL CODE 
      WRITE(IMAG,928) 
      CALL CODE 
      WRITE(OPND,942) 
      CALL LINE(IMAG,IX)
C----I/P LU 
1110  IF(LU.NE.1)GOTO 1115
      WRITE(LU,912) 
1115  READ(LU,115)IBUF
      IF(IBUF(1).EQ.2H/E)GOTO 2000
C----INCREMENT LU COUNT 
      LUCNT=LUCNT+1 
      CALL CODE 
      READ(IBUF,*)LUX 
C----I/P HALF/FULL DUPLEX 
      IF(LU.NE.1)GOTO 1120
      WRITE(LU,914) 
1120  IDUX=0
      IF(RBIN(2HFU,2HHA,LU))IDUX=IDUX+100000B 
      IF(LU.NE.1)GOTO 1121
      WRITE(LU,915) 
1121  IF(RBIN(2HYE,2HNO,LU))IDUX=IDUX+40000B
C----I/P BAUD RATE
      CALL IBAUD(LU,K,J)
      J=J+(400B*J)
C----I/P CODE TYPE,ASCII/EBCDIC 
      IBR=0 
      IF(LU.NE.1)GOTO 1125
      WRITE(LU,943) 
1125  CONTINUE
      ISYNC=50
      IDUX=IDUX+8 
      IF(RBIN(2HEB,2HAS,LU))GOTO 1130 
      ISYNC=22
      IDUX=IDUX-1 
      IF(LU.NE.1)GOTO 1126
      WRITE(LU,944) 
1126  IF(RBIN(2HVR,2HCR,LU))IBR=IBR+100000B 
C-----I/P CRR/VRC BLOCK CHECK 
1130  IF(LU.NE.1)GOTO 1135
      WRITE(LU,945) 
C----I/P HASP WORK STATION
1135  IF(RBIN(2HYE,2HNO,LU))IBR=IBR+10000B
1140  IF(LU.NE.1)GOTO  1145 
      WRITE(LU,946) 
C----I/P SWITCHED LINE
1145  IF(RBIN(2HYE,2HNO,LU))IBR=IBR+2 
C----I/P PRIMARY STATION
      IF(LU.NE.1)GOTO 1150
      WRITE(LU,947) 
1150  IF(RBIN(2HYE,2HNO,LU))IBR=IBR+1 
C----I/P CHARACTER TRACE LENGTH 
      IF(LU.NE.1)GOTO 1155
      WRITE(LU,960) 
1155  READ(LU,*)IC
C----I/P EVENT TRACE LENGTH 
      IF(LU.NE.1)GOTO 1156
      WRITE(LU,961) 
1156  READ(LU,*)IE
C----INSURE EVENT TRACE LENGTH = 3 OR MORE
      IF(IE.LT.3)IE=3 
      IL=76 
      ITRCE=IE+IC 
      IS=60 
      ITRCE=ITRCE+IL
C----O/P DEC ITRCE
      CALL FLUSH(IMAG,40) 
      CALL CODE 
      WRITE(IMAG,905) 
      CALL CODE 
      WRITE(OPND,180)ITRCE
      CALL LINE(IMAG,IX)
C----O/P OCT IDUX 
      CALL FLUSH(IMAG,40) 
      CALL CODE 
      WRITE(IMAG,906) 
      CALL CODE 
      WRITE(OPND,200)IDUX 
      CALL LINE(IMAG,IX)
C----O/P OCT ISYNC
      CALL CODE 
      WRITE(OPND,200)ISYNC
      CALL LINE(IMAG,IX)
C----O/P OCT BAUD RATE
      CALL CODE 
      WRITE(OPND,200)J
      CALL LINE(IMAG,IX)
C---- O/P OCT LU
      CALL CODE 
      WRITE(OPND,200)LUX
      CALL LINE(IMAG,IX)
C----O/P BSS IS-5 
      CALL CODE 
      WRITE(IMAG,920) 
      ISYNC=IS-5
      CALL CODE 
      WRITE(OPND,180)ISYNC
      CALL LINE(IMAG,IX)
C----O/P OCT IBR
      CALL CODE 
      WRITE(IMAG,906) 
      CALL CODE 
      WRITE(OPND,200)IBR
      CALL LINE(IMAG,IX)
C----O/P DEC IC 
      CALL CODE 
      WRITE(IMAG,905) 
      CALL CODE 
      WRITE(OPND,180)IC 
      CALL LINE(IMAG,IX)
C----O/P BSS ITRCE-IS 
      ITRCE=ITRCE-IS-2
      CALL CODE 
      WRITE(IMAG,920) 
      CALL CODE 
      WRITE(OPND,180)ITRCE
      CALL LINE(IMAG,IX)
      GOTO 1110 
C----O/P NOP     END OF LIST
2000  CALL FLUSH(IMAG,40) 
      CALL CODE 
      WRITE(IMAG,921) 
      CALL LINE(IMAG,IX)
C----TEST FOR CONTROL BLOCK GENERATION
      IF(LU.NE.1)GOTO 2100
      WRITE(LU,952) 
2100  IF(RBIN(2HNO,2HYE,LU))GOTO 2500 
C----O/P ENT CB$
      CALL CODE 
      WRITE(IMAG,903) 
      CALL CODE 
      WRITE(OPND,956) 
      CALL LINE(IMAG,IX)
      CALL CODE 
      WRITE(IMAG,933) 
C----DEFINE START SEGMENT 
      CALL SEGDF(LU,ASCII)
C----O/P CB$  ASC 3,ABCDE 
      CALL CODE 
      WRITE(LABLE,956)
      CALL LINE(IMAG,IX)
C----I/P ACTIVE CONTROL BLOCKS
      IF(LU.NE.1)GOTO 2200
      WRITE(LU,953) 
2200  READ(LU,*)LQ
C----I/P RESERVE CONTROL BLOCKS 
2210  CONTINUE
      IF(LU.NE.1)GOTO 2300
      WRITE(LU,954) 
2300  READ(LU,*)KK
      IF(KK.LT.1)GOTO 2210
      KK=LQ+KK
C----I/P STACK LENGTH 
2310  IF(LU.NE.1)GOTO 2400
      WRITE(LU,955) 
2400  READ(LU,*)JS
      IF(JS.LT.4)GOTO 2310
C----O/P DEC LQ 
      CALL FLUSH(IMAG,40) 
      CALL CODE 
      WRITE(IMAG,905) 
      CALL CODE 
      WRITE(OPND,180)LQ 
      CALL LINE(IMAG,IX)
C----O/P DEC KK 
      CALL CODE 
      WRITE(OPND,180)KK 
      CALL LINE(IMAG,IX)
C---O/P DEC LUCNT 
      CALL CODE 
      WRITE(OPND,180)LUCNT
      CALL LINE(IMAG,IX)
C----O/P DEC 18+2(JS) 
      JS=2*JS 
      J=JS+18 
      CALL CODE 
      WRITE(OPND,180)J
      CALL LINE(IMAG,IX)
C----O/P DEF *+1
      CALL FLUSH(IMAG,40) 
      CALL CODE 
      WRITE(IMAG,957) 
      CALL LINE(IMAG,IX)
C----O/P BSS
      J=J*KK
      CALL CODE 
      WRITE(IMAG,920) 
      CALL CODE 
      WRITE(OPND,180)J
      CALL LINE(IMAG,IX)
2500  CONTINUE
C----O/P END
      CALL FLUSH(IMAG,40) 
      CALL CODE 
      WRITE(IMAG,908) 
      CALL LINE(IMAG,IX)
C----CLOSE DISK FILE
      CALL PACK(-1,-1)
C----SETUP JOB FILE FOR ASSEMBLER 
      JF=EXEC(18,FNAME,NSECT) 
      CALL IPUT(124B,JF)
      CALL IPUT(125B,JF)
      JS=IGET(161B) 
      CALL IPUT(177B,JS)
C----EXECUTE ASSEMBLER
      CALL EXEC(10,ASMB,2,99) 
      STOP
117   OPND(J)=2H,6
      OPND(J+1)=2H
      GOTO 119
118   OPND(J)=IOR(IAND(IBUF(J),177400B),54B)
      OPND(J+1)=2H6 
      OPND(J+2)=2H
      GOTO 119
      END 
      SUBROUTINE SEGDF(LU,INAM) 
C----GENERATE RELOCATABLE BINARY FOR START SEGMENT
      DIMENSION INAM(1) 
      DIMENSION IBIN(44)
      DATA IBIN/10400B,20000B,166456B,22123B,52122B,52040B,1,0, 
     -         0,5,143B,0,0,0,0,0,0,
     -         3400B,40001B,6246B,22123B,52122B,52000B,0, 
     -         4400B,100002B,0,0,0,0,51524B,51124B,20402B,
     -         3000B,60101B,176103B,0,100000B,16002B, 
     -         2000B,120001B,120001B,0,0/ 
C     ARRAY CONTAINS RELOCATABLE BINARY FOR FOLLOWIN
C     NAM $STRT,5 
C     ENT $STRT 
C     ENT MAIN
C     EXT STRT! 
CSTRT JSB STRT! 
C     END 
      CALL FLUSH(IBIN(28),3)
      IF(LU.NE.1)GOTO 10
      WRITE(LU,5) 
5     FORMAT("MAIN PROGRAM =_") 
10    READ(LU,15)(IBIN(J),J=28,30)
15    FORMAT(3A2) 
      IBIN(30)=IAND(IBIN(30),177400B)+1 
      IBIN(27)=IBIN(26) 
      DO 20 J=28,33 
20    IBIN(27)=IBIN(27)+IBIN(J) 
      CALL FLUSH(IBIN(4),3) 
      IF(LU.NE.1)GOTO 25
      WRITE(LU,26)
26    FORMAT("START SEGMENT=_") 
25    READ(LU,15)(IBIN(J),J=4,6)
      IBIN(3)=IBIN(2) 
      DO 40 J=4,17
40    IBIN(3)=IBIN(3)+IBIN(J) 
      INAM(1)=IBIN(4) 
      INAM(2)=IBIN(5) 
      INAM(3)=IBIN(6) 
      JBINC=IGET(102B)
      ITRK=IAND(JBINC,177400B)/400B 
      IF(ITRK.LT.0)ITRK=ITRK+400B 
      ISECT=IAND(JBINC,377B)
      CALL EXEC(-2,102B,IBIN,44,ITRK,ISECT) 
      ISECT=ISECT+1 
      IF(ISECT.LT.IGET(116B))GOTO 30
      ISECT=0 
      ITRK=ITRK-1 
30    J=ITRK*400B+ISECT 
      IF(J.EQ.IGET(160B))GOTO 999 
      CALL IPUT(102B,J) 
      RETURN
999   CALL IPUT(101B,-1)
      WRITE(1,1000) 
1000  FORMAT("JBIN OVERFLOW") 
      RETURN
      END 
      INTEGER FUNCTION FINDL(L1,L2,L3)
C     THIS FUNCTION FINDS THE FIRST ITEM IN ARRAY L1 WHICH
C     MATCHES L2. L3 CONTAINS THE NUMBER OF ITEMS IN L2.
C     THE RESULTANT IS THE INDEX INTO L2, ZERO INDICATES
C     NO FIND.
      DIMENSION L1(6,1),L2(3) 
      DO 1 J=1,L3 
      DO 2 K=1,3
      IF(L1(K,J).NE.L2(K))GOTO 1
2     CONTINUE
      FINDL=J 
      RETURN
1     CONTINUE
      FINDL=0 
      RETURN
      END 
      LOGICAL FUNCTION RBIN(L1,L2,LU) 
C     THIS FUNCTION READS 2 ASCII CHARACTERS FROM THE DEVICE
C     SPECIFIED BY LU. IF THE ANSWER MATCHES L1,THE RESULT IS 
C     TRUE. IF THE ANSWER MATCHES L2 THE ANSWER IS FALSE. IF
C     THE ANSWER MATCHES NEITHER,THE OPERATOR IS PROMPTED TO
C     INPUT CORRECT REPLIES.
1     READ(LU,10)IN 
10    FORMAT(A2)
      IF(IN.EQ.L1)GOTO 20 
      IF(IN.EQ.L2)GOTO 30 
      WRITE(1,40)L1,L2
40    FORMAT("INCORRECT INPUT"/"ENTER ",A2," OR "A2)
      IF(LU.NE.1)PAUSE
      GOTO 1
20    RBIN=.TRUE. 
      RETURN
30    RBIN=.FALSE.
      RETURN
      END 
      SUBROUTINE COMNT(L1,L2,L3,L4) 
C     THIS SUBROUTINE OUTPUTS COMMENTS TO THE SOURCE FILE.
C----L1= FORMAT 
C----L2=VARIABLE
C----L3=ARRAY LENGTH
C----L4=SECTOR INDEX
      DIMENSION IMAG(20),L2(1)
10    FORMAT("***LU ",I2) 
20    FORMAT("***",3A2) 
30    FORMAT("***",I4," BAUD")
40    FORMAT("*** FULL DUPLEX") 
50    FORMAT("*** SECONDARY CHAN.") 
60    FORMAT("*** ECHO")
70    FORMAT("*** SYNCHRONOUS") 
      CALL FLUSH(IMAG,20) 
      GOTO(1,2,3,4,5,6,7)L1 
1     CALL CODE 
      WRITE(IMAG,10)L2
900   CALL LINE(IMAG,L4)
      RETURN
2     CALL CODE 
      WRITE(IMAG,20)(L2(J),J=1,L3)
      GOTO 900
3     CALL CODE 
      WRITE(IMAG,30)L2
      GOTO 900
4     CALL CODE 
      WRITE(IMAG,40)
      GOTO 900
5     CALL CODE 
      WRITE(IMAG,50)
      GOTO 900
6     CALL CODE 
      WRITE(IMAG,60)
      GOTO 900
7     CALL CODE 
      WRITE(IMAG,70)
      GOTO 900
      END 
      SUBROUTINE IBAUD(LU,K,J)
C     THIS SUBROUTINE INPUTS BAUD RATE AND ENCODES IT. K CONTAINS 
C     THE BAUD RATE AS INPUT, AND J CONTAINS THE ENCODED RATE.
      INTEGER RATE(15)
      DATA RATE/110,134,150,220,300,440,600,880,
     *          1200,1760,2400,4800,
     *          3600,7200,9600/ 
913   FORMAT("BAUD RATE=_") 
914   FORMAT("INVALID BAUD RATE") 
1     CONTINUE
      IF(LU.NE. 1)GOTO 150
      WRITE(LU,913) 
150   READ(LU,*)IBR 
      K=IBR 
      IF(K.EQ.0)GOTO 200
C----ENCODE BAUD RATE 
      DO 190 J=1,15 
      IF(RATE(J).EQ.IBR)GOTO 195
190   CONTINUE
      J=0 
      WRITE(1,914)
      IF(LU.NE.1)PAUSE
      GOTO 1
195   RETURN
200   J=0 
      RETURN
      END 
      SUBROUTINE LINE(IL,IX)
C     THIS SUBROUTINE PACKS 20 CHARACTER SOURCE LINES.
      DIMENSION IL(1) 
      CALL PACK(5000B,IX) 
      DO 10 L=1,10
10    CALL PACK(IL(L),IX) 
      RETURN
      END 
      SUBROUTINE PACK(II,IX)
C     THIS SUBROUTINE BUILDS DISK FILE C$$$1. 
      INTEGER FNAME(3),DISK(128)
      INTEGER RSECT 
      IF(IX)900,100,200 
100   CALL CODE 
      WRITE(FNAME,110)
110   FORMAT("C$$$1 ")
      RSECT=0 
      IX=1
200   DISK(IX)=II 
      IF(IX.NE.128)GOTO 210 
      CALL EXEC(15,3,DISK,128,FNAME,RSECT)
      RSECT=RSECT+1 
      IX=0
210   IX=IX+1 
      IY=IX 
      RETURN
900   DISK(IY)=0
      DISK(IY+1)=-1 
      CALL EXEC(15,3,DISK,128,FNAME,RSECT)
      RSECT=RSECT+1 
      WRITE(1,910)RSECT 
910   FORMAT("SECTORS="I5)
      RETURN
      END 
      SUBROUTINE FLUSH(IT,L)
C     THIS SUBROUTINE FILLS ARRAY IT WITH SPACES. 
      DIMENSION IT(1) 
      DO 10 J=1,L 
10    IT(J)=2H
      RETURN
      END 
      END$
::
:ST,S,$TC17,5 
ASMB,L,C
      NAM IGET,7
      ENT IGET
IGET  NOP 
      LDB IGET,I
      ISZ IGET
      LDA IGET,I
      LDA A,I 
      LDA A,I 
      JMP B,I 
A     EQU 0 
B     EQU 1 
      END 
::
:ST,S,$TC18,5 
ASMB,L,C
      NAM IPUT,7
      ENT IPUT
      EXT .ENTR,EXEC
ADDR  NOP 
VALU  NOP 
IPUT  NOP 
      JSB .ENTR 
      DEF ADDR
      LDA VALU,I
      LDB ADDR,I
      JSB EXEC
      DEF *+2 
      DEF N19$
      JMP IPUT,I
N19$  DEC -19 
      END 
::
:CO MOUNT TAPE #12, TYPE :GO
:PA