Trailing-Edge
-
PDP-10 Archives
-
decuslib20-02
-
decus/20-0050/tbltel.for
There is 1 other file named tbltel.for in the archive. Click here to see a list.
SUBROUTINE TBLTEL
C
C TBLTRN ROUTINE TO PERFORM TEL OPERATION
C
C DONALD E. BARTH, CHEM. DEPT., HARVARD UNIVERSITY
C
COMMON/TBLTRN/I,IADDRS,IADJST,IBASE,IBLANK,IDGT(16),
1IERR,IFILL,IFKNT,IKODE,ILEFT,ILINE,ILPT,ILTR,IBYTE,
2IMASK,LMAX,NMORE,IMOST,INSERT,IOCT(13),IOPRTR,IOUT,
3IPAREN,IPNCTN(11),IPRCN,IRADIX,IREAD,IREPT,IRIGHT,
4ISHIFT,ISIGN,ISTAR,ISTORE(478),ITEN,ITEST,ITITLE(6),
5ITTY,IWIDE,IWRITE,J,JADJST,JBASE,JBLANK,JERR,KPAREN,
6JFKNT,JKODE(37),JLEFT,JMASK,JMORE,JPAREN,JRADIX,LOOP,
7JRIGHT,JSHIFT,JSIGN,K,KADJST,KBASE,KERR,KIND,KLINE,
8KLM,KLTR,KMASK,KNT,KNTLTR,KNTWRD,KODE,KRADIX,IDBG,
9KREAD,KSHIFT,L,LEAST,LETTER(160),LMASK,LOCK,LSTNEW,
1LTTR(160),M,MASK,MASTER(5000),MAX,MLEFT,MORE,MOST,
2MRIGHT,MULT,N,NEW,NEXT,NSIGN,NTITLE(6),NUMBER,LRADIX,
3KMAX,INLINE,JPNCTN(50),KPNCTN(50),LPNCTN,JOPRTR,NLTR,
4JBYTE,ILOOP,ISKIP,IVALUE,INSN(6),JNSN,IMAX,JMAX,
5KNSN,MLTR,JLTR,JLOOP,IPFX,JPFX,LSIGN,IIARG,JJARG,
6KKARG,LLARG,JVALUE,MIN,IAC,IARG,JARG,KARG,LARG,JSTFY,
7LENGTH(20),LNGMIN,IORDER,IRMV,KSIGN
C
C *************************************
C * SYMBOL IN RANGE OF TEL OPERATOR *
C *************************************
C
1 IF(KIND.EQ.3)GO TO 30
IF(KSIGN.EQ.0)GO TO 2
IDBG=ILPT
IF(IDBG.EQ.ITTY)JBLANK=1
IF(KIND.NE.2)GO TO 14
IF(NUMBER.EQ.0)GO TO 7
GO TO 24
2 IDBG=ITTY
JBLANK=1
IF(KIND.NE.2)GO TO 3
IF(NUMBER.EQ.0)GO TO 7
KODE=100+NUMBER
CALL TBLDBG
GO TO 30
3 IF(NEW.EQ.0)GO TO 8
KODE=-NEW
CALL TBLDBG
C
C SEARCH FOR OTHER SYMBOLS WITH SAME NAME
4 K=LNGMIN
IF(NEW.LT.LNGMIN)K=MASTER(NEW+1)
L=IRIGHT-ILEFT+3
5 NEW=K-1
K=MASTER(K)
IF(K.EQ.0)GO TO 30
IF(MASTER(NEW).LE.0)GO TO 5
IF((NEW-K).NE.L)GO TO 5
I=K
J=ILEFT
6 I=I+1
IF(MASTER(I).NE.LETTER(J))GO TO 5
J=J+1
IF(J.LE.IRIGHT)GO TO 6
GO TO 1
C
C REVERSE SELECTION OF TBLDBG OUTPUT IF NUMBER.EQ.0
7 KSIGN=1-KSIGN
GO TO 30
C
C SEARCH ISTORE IF NUMBER FOLLOWED BY ASTERISK
8 I=1
J=ITEN-1
9 IF(JKODE(I).EQ.0)GO TO 11
IF(JKODE(I).EQ.J)GO TO 10
I=I+1
GO TO 9
10 ITEN=J
11 I=1
12 IF(ISTORE(I).EQ.0)GO TO 30
J=I+2
I=J+ISTORE(I)
IF(ISTORE(J-1).NE.ITEN)GO TO 12
K=I-1
L=5-IRIGHT+ILEFT
WRITE(IDBG,13)ITEN,(IBLANK,M=1,L),
1(LETTER(M),M=ILEFT,IRIGHT),(ISTORE(M),M=J,K)
13 FORMAT(19H PRE-ASSEMBLED CODE,1I3,25X,6A1,1X,80A1)
GO TO 12
C
C LIST SYMBOL CELL IF KSIGN.NE.0
14 IF(NEW.EQ.0)GO TO 8
I=NEW+1
WRITE(IDBG,15)I,MASTER(I),NEW,MASTER(NEW)
15 FORMAT(1X,2I6)
I=MASTER(I)+1
NUMBER=NEW-1
K=NUMBER
GO TO 25
16 K=K-1
WRITE(IDBG,17)K,MASTER(K)
17 FORMAT(1X,1I6,1X,1A1)
IF(K.GT.I)GO TO 16
K=MASTER(NEW)
IF(K.EQ.1)GO TO 23
IF(K.EQ.2)GO TO 18
IF(K.EQ.8)GO TO 18
IF(K.EQ.29)GO TO 18
IF(K.NE.66)GO TO 4
18 IF(MASTER(NUMBER).GE.0)GO TO 4
19 NUMBER=-MASTER(NUMBER)
I=NUMBER+1
WRITE(IDBG,15)I,MASTER(I),NUMBER,MASTER(NUMBER)
I=MASTER(I)
IF(K.NE.8)GO TO 29
20 NUMBER=NUMBER-1
IF(NUMBER.LE.I)GO TO 4
K=NUMBER-MASTER(NUMBER)
WRITE(IDBG,15)NUMBER,MASTER(NUMBER)
21 NUMBER=NUMBER-1
IF(NUMBER.LT.K)GO TO 22
WRITE(IDBG,17)NUMBER,MASTER(NUMBER)
GO TO 21
22 IF(NUMBER.LE.I)GO TO 4
WRITE(IDBG,15)NUMBER,MASTER(NUMBER)
GO TO 20
23 IF(MASTER(NUMBER).LT.0)GO TO 19
IF(MASTER(NUMBER).EQ.0)GO TO 4
NUMBER=MASTER(NUMBER)/8080
C
C LIST TABLE ENTRY IF KSIGN.NE.0
24 IF(NUMBER.GT.MOST)GO TO 30
25 IF(MASTER(NUMBER).LT.8)GO TO 27
J=0
CALL DANUMB(1,MASTER(NUMBER),8,IOCT,J,13,13)
KODE=MASTER(NUMBER)
L=KODE/101
M=L/5
N=M/16
KODE=KODE-101*L
L=L-5*M
M=M-16*N
WRITE(IDBG,26)NUMBER,MASTER(NUMBER),
1 (IOCT(J),J=1,13),N,M,L,KODE
26 FORMAT(1X,1I6,1I13,13A1/1X,4X,
11I6,6H*8080+,1I2,5H*505+,1I1,5H*101+,1I3)
GO TO 28
27 WRITE(IDBG,26)NUMBER,MASTER(NUMBER)
28 IF(NEW.EQ.0)GO TO 30
IF(NUMBER.LT.LEAST)GO TO 23
IF(NUMBER.EQ.(NEW-1))GO TO 16
29 NUMBER=NUMBER-1
IF(NUMBER.GT.I)GO TO 25
GO TO 4
C
C *******************************
C * RETURN TO CALLING PROGRAM *
C *******************************
C
30 RETURN
END