Google
 

Trailing-Edge - PDP-10 Archives - decuslib10-02 - 43,50250/tbltel.f4
There are no other files named tbltel.f4 in the archive.
      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