Google
 

Trailing-Edge - PDP-10 Archives - decuslib10-02 - 43,50250/tblstr.f4
There are no other files named tblstr.f4 in the archive.
      SUBROUTINE TBLSTR
C
C     ROUTINE TO HANDLE TBLTRN TEXT STRINGS
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     KODE=4, ' (APOSTROPHE OR SINGLE QUOTE) OPERATOR
C     KODE=36, '' (DOUBLE APOSTROPHE) OPERATOR
    1 ILEFT=IRIGHT
    2 ILEFT=ILEFT+1
      IF(ILEFT.GT.MLTR)GO TO 4
      IF(LETTER(ILEFT).EQ.IBLANK)GO TO 2
      IRIGHT=ILEFT
    3 IRIGHT=IRIGHT+1
      IF(IRIGHT.GT.MLTR)GO TO 4
      IF(LETTER(IRIGHT).NE.LETTER(ILEFT))GO TO 3
    4 IF(LOOP.NE.0)GO TO 6
      IF(IRIGHT.LE.(LMAX-5))GO TO 6
      IF(ILINE.EQ.JERR)GO TO 6
      JERR=ILINE
      JBLANK=1
      WRITE(ITTY,5)ILINE
    5 FORMAT(1X,4HLINE,1I6,
     132H PROBABLY EXCEEDS MAXIMUM LENGTH)
    6 ILEFT=ILEFT+1
      IF(ISKIP.NE.0)GO TO 81
      IF(IFKNT.NE.0)GO TO 80
      IF(IARG.EQ.0)GO TO 7
      IF(ILEFT.LE.LARG)GO TO 7
      IF(JARG.GT.0)JARG=JARG-1
    7 IF(KNTWRD.NE.0)GO TO 8
      IADDRS=0
      IKODE=KODE
    8 KNTWRD=KNTWRD+1
      IF(IOPRTR.EQ.23)GO TO 27
      IF(IOPRTR.EQ.72)GO TO 33
      IF(IOPRTR.EQ.118)GO TO 27
      IF(IOPRTR.EQ.15)GO TO 9
      IF(IOPRTR.NE.37)GO TO 24
C
C     DEFINE SYMBOL AS TEXT STRING
    9 IF(MASTER(IADDRS).EQ.16)GO TO 18
      IF(IERR.NE.0)GO TO 24
      IF(MASTER(IADDRS).EQ.8)GO TO 10
      IF(INSERT.EQ.0)GO TO 24
      GO TO 11
   10 IF(MASTER(IADDRS-1).NE.0)GO TO 12
C     DEFINE NEW DATA CELL IF NONE PRESENT
   11 LSTNEW=MASTER(IADDRS+1)-1
      IF((LSTNEW-IRIGHT+ILEFT-4).LE.
     1(MOST+NEXT))GO TO 84
      MASTER(IADDRS)=8
      MASTER(IADDRS-1)=-LSTNEW
      MASTER(LSTNEW)=-IADDRS+1
      MASTER(LSTNEW-1)=0
      LEAST=LSTNEW
      IF(INSERT.EQ.0)GO TO 15
      LEAST=LEAST-2
      GO TO 14
   12 LSTNEW=-MASTER(IADDRS-1)
      IF((LSTNEW-IRIGHT+ILEFT-3).LE.
     1(MOST+NEXT))GO TO 84
      LEAST=MASTER(LSTNEW+1)
      I=LSTNEW-1
   13 I=I-MASTER(I)-2
      IF(I.GT.LEAST)GO TO 13
      IF(INSERT.EQ.0)GO TO 15
C     DEFINE NUMBER OF ARGUMENTS
   14 MOST=MOST-MULT
      INSERT=0
      NEXT=0
      MULT=0
      MASK=0
      KPAREN=0
      MASTER(LEAST)=MASTER(MOST+1)
   15 LEAST=LEAST-2
      MASTER(LEAST+1)=IRIGHT-ILEFT
      I=IRIGHT
      IF(IRIGHT.LE.ILEFT)GO TO 17
      IF(KODE.EQ.36)GO TO 45
C     DEFINE AS DIRECT COPY OF TEXT
   16 I=I-1
      MASTER(LEAST)=LETTER(I)
      LEAST=LEAST-1
      IF(I.GT.ILEFT)GO TO 16
   17 MASTER(LSTNEW+1)=LEAST
      MASTER(LEAST)=0
      GO TO 82
C
C     RENAME AS FOR STATEMENT A=.'/,,,/
   18 IF(KNTWRD.NE.4)GO TO 24
      IF(KODE.EQ.36)GO TO 45
      IF(ILEFT.EQ.IRIGHT)GO TO 82
      IF(LETTER(ILEFT).NE.IBLANK)GO TO 19
      ILEFT=ILEFT+1
      GO TO 18
   19 J=IRIGHT
   20 J=J-1
      IF(LETTER(J).EQ.IBLANK)GO TO 20
      INDEX=J-ILEFT+1
      I=INDEX
      IF(I.GT.20)I=20
      LIMIT=LENGTH(I)
      IF(LIMIT.EQ.0)LIMIT=LNGMIN
      I=0
   21 KOUNT=J
   22 NEW=LIMIT-3
      LIMIT=MASTER(LIMIT)
      IF(LIMIT.LE.0)GO TO 83
      IF(MASTER(NEW+2).LE.2)GO TO 22
      IF((LIMIT+INDEX).EQ.NEW)GO TO 23
      IF(NEW.LT.LNGMIN)GO TO 22
      IF(INDEX.LT.20)LIMIT=LNGMIN
      GO TO 22
   23 IF(MASTER(NEW).NE.LETTER(KOUNT))GO TO 21
      NEW=NEW-1
      KOUNT=KOUNT-1
      IF(KOUNT.GE.ILEFT)GO TO 23
      NEW=NEW+INDEX+2
      IF(NEW.EQ.IADDRS)GO TO 21
      MASTER(IADDRS)=MASTER(NEW)
      MASTER(IADDRS-1)=MASTER(NEW-1)
      IRMV=NEW
      GO TO 82
C
C     WRITE THE TEXT STRING ONTO LPT OR TTY
   24 IF(ITEST.NE.0)GO TO 82
      IF(IRIGHT.LE.ILEFT)GO TO 82
      J=IRIGHT-1
      IF(KODE.EQ.36)GO TO 26
      IF(IWRITE.EQ.ITTY)GO TO 26
      WRITE(IWRITE,25)(LETTER(I),I=ILEFT,J)
   25 FORMAT(150A1)
      GO TO 82
   26 WRITE(ITTY,25)IBLANK,(LETTER(I),I=ILEFT,J)
      JBLANK=1
      GO TO 82
C
C     ********************************************
C     *  SYMBOL IN RANGE OF TTL OR NSN OPERATOR  *
C     ********************************************
C
   27 IF(IRIGHT.LE.ILEFT)GO TO 79
      IF(LETTER(ILEFT).NE.IBLANK)GO TO 28
      ILEFT=ILEFT+1
      GO TO 27
   28 IF(IOPRTR.EQ.23)GO TO 30
      JNSN=0
   29 JNSN=JNSN+1
      INSN(JNSN)=LETTER(ILEFT)
      IF(JNSN.EQ.6)GO TO 79
      GO TO 32
   30 KNTLTR=0
   31 KNTLTR=KNTLTR+1
      ITITLE(KNTLTR)=LETTER(ILEFT)
      IF(KNTLTR.EQ.6)GO TO 79
   32 ILEFT=ILEFT+1
      IF(IRIGHT.LE.ILEFT)GO TO 79
      IF(LETTER(ILEFT).EQ.IBLANK)GO TO 32
      IF(IOPRTR.EQ.23)GO TO 31
      GO TO 29
C
C     ***********************************
C     *  TEXT IN RANGE OF ACC OPERATOR  *
C     ***********************************
C
   33 I=0
   34 IF(IRIGHT.LE.ILEFT)GO TO 79
      IF(LETTER(ILEFT).NE.IBLANK)GO TO 35
      ILEFT=ILEFT+1
      GO TO 34
   35 I=I+1
      IF(I.GT.LPNCTN)GO TO 37
      IF(JPNCTN(I).NE.LETTER(ILEFT))GO TO 35
   36 IF(I.EQ.LPNCTN)GO TO 37
      JPNCTN(I)=JPNCTN(I+1)
      KPNCTN(I)=KPNCTN(I+1)
      I=I+1
      GO TO 36
C
C     NOTE --- IF MORE THAN 50 CHARACTERS ARE TO BE
C     ASSIGNED TO CHARACTER CLASSES, THEN THE DIMENSIONS
C     OF JPNCTN AND OF KPNCTN, AND THE FOLLOWING TEST
C     MUST BE CHANGED.
C
   37 IF(I.GT.50)GO TO 83
      LPNCTN=I
      JPNCTN(I)=LETTER(ILEFT)
      J=7
   38 J=J+1
      K=1
   39 IF(K.EQ.I)GO TO 40
      IF(KPNCTN(K).EQ.J)GO TO 38
      K=K+1
      GO TO 39
   40 KPNCTN(I)=J
   41 ILEFT=ILEFT+1
      IF(IRIGHT.LE.ILEFT)GO TO 44
      IF(LETTER(ILEFT).EQ.IBLANK)GO TO 41
      I=0
   42 I=I+1
      IF(I.GT.LPNCTN)GO TO 43
      IF(JPNCTN(I).NE.LETTER(ILEFT))GO TO 42
      KPNCTN(LPNCTN)=KPNCTN(I)
      GO TO 79
   43 LPNCTN=LPNCTN-1
      GO TO 79
   44 KPNCTN(I)=5
      GO TO 79
C
C     ************************************
C     *  DEFINE SYMBOL AS COMPILED TEXT  *
C     ************************************
C
   45 KIND=0
      NEW=LEAST+1
      I=ILEFT-1
C
C     DETERMINE COMPILATION CODE IDENTIFIER CHARACTER
C     THIS IS INITIALLY THE ASTERISK
      NUMBER=0
   46 IF(NUMBER.EQ.LPNCTN)GO TO 83
      NUMBER=NUMBER+1
      IF(KPNCTN(NUMBER).NE.7)GO TO 46
C
C     FIND NEXT SYMBOL IN TEXT STRING
   47 N=KIND
   48 KIND=0
      ILEFT=I+1
      K=ILEFT
      INDEX=0
   49 I=I+1
      IF(I.GE.IRIGHT)GO TO 55
      J=LETTER(I)
      DO 51 L=1,11
      IF(J.NE.IPNCTN(L))GO TO 51
      IF(L.EQ.3)GO TO 53
      IF(KIND.EQ.0)GO TO 50
      IF(KIND.NE.L)GO TO 55
      GO TO 49
   50 KIND=L
      GO TO 49
   51 CONTINUE
      IF(KIND.GT.0)GO TO 55
      IF(KIND.LT.-1)GO TO 49
      DO 52 L=1,10
      IF(J.NE.IDGT(L))GO TO 52
      KIND=-1
      K=K+1
      IF(INDEX.LE.10000)INDEX=(10*INDEX)+L-1
      GO TO 49
   52 CONTINUE
      IF(KIND.EQ.0)GO TO 54
      KIND=-2
      GO TO 49
C
C     ASTERISK IN TEXT
   53 IF(KIND.GT.0)GO TO 55
      IF(KIND.EQ.-1)GO TO 70
      IF(KIND.EQ.-2)GO TO 49
   54 KIND=-3
      GO TO 49
C
C     MATCH SYMBOL IN ORIGINAL SYMBOL DICTIONARY
   55 I=I-1
      IF(KIND.EQ.0)GO TO 75
      IF(KIND.EQ.1)GO TO 48
      IF(KIND.EQ.2)GO TO 71
      IF(KIND.EQ.-1)GO TO 71
      J=1
      KODE=I-K+1
   56 M=J+2
      J=ISTORE(J)+M
      IF(M.EQ.J)GO TO 71
      IF(KODE.NE.(J-M))GO TO 56
      L=K
   57 IF(ISTORE(M).NE.LETTER(L))GO TO 56
      M=M+1
      L=L+1
      IF(M.LT.J)GO TO 57
C
C     CHECK IF CODE CAN BE USED WITH INTEGER PREFIX
      J=J-L+K-1
      J=ISTORE(J)
      IF(J.EQ.1001)GO TO 71
      IF(KIND.NE.-2)GO TO 59
      M=0
   58 M=M+1
      IF(JKODE(M).EQ.0)GO TO 71
      IF(JKODE(M).NE.J)GO TO 58
      IF(INDEX.NE.0)GO TO 59
      J=J+1
      KIND=0
C
C     MAKE BE COMPILED CODE (FORM A=.''/,/)
   59 IF(MASTER(IADDRS).NE.16)GO TO 62
      IF(KIND.EQ.-2)GO TO 60
      INDEX=0
      GO TO 61
   60 J=J+1
   61 MASTER(IADDRS)=J
      MASTER(IADDRS-1)=INDEX
      GO TO 82
C
C     INSERT COMPILED CODE INTO DEFINITION
   62 M=0
      CALL DANUMB(0,J,10,IOCT,M,0,13)
      IF(N.GE.0)GO TO 63
      MASTER(LEAST)=IBLANK
      LEAST=LEAST-1
   63 IF((LEAST-M-1).LE.MOST)GO TO 78
      DO 64 L=1,M
      MASTER(LEAST)=IOCT(L)
   64 LEAST=LEAST-1
      MASTER(LEAST)=JPNCTN(NUMBER)
      LEAST=LEAST-1
      IF(KIND.EQ.-2)GO TO 68
      IF(J.EQ.6)GO TO 75
      IF(J.EQ.7)GO TO 75
      KIND=3
      IF(J.EQ.4)GO TO 65
      IF(J.EQ.36)GO TO 65
      IF(J.NE.83)GO TO 47
C
C     DETERMINE END OF TEXT STRING WITHIN TEXT STRING
   65 IF((I+1).EQ.IRIGHT)GO TO 47
      I=I+1
      IF(LETTER(I).EQ.IBLANK)GO TO 65
      ILEFT=I
      IF((I+1).EQ.IRIGHT)GO TO 73
      GO TO 67
   66 IF(LETTER(I).EQ.LETTER(ILEFT))GO TO 73
   67 I=I+1
      IF((I+1).NE.IRIGHT)GO TO 66
      GO TO 73
C
C     INSERT INTEGER PREFIX AS SUFFIX OF COMPILED CODE
   68 IF((LEAST-K+ILEFT-3).LE.MOST)GO TO 78
      IF(INDEX.EQ.1)GO TO 69
      MASTER(LEAST)=IDGT(2)
      MASTER(LEAST-1)=IDGT(3)
      MASTER(LEAST-2)=JPNCTN(NUMBER)
      LEAST=LEAST-3
   69 MASTER(LEAST)=LETTER(ILEFT)
      LEAST=LEAST-1
      ILEFT=ILEFT+1
      IF(ILEFT.LT.K)GO TO 69
      KIND=-1
      GO TO 47
C
C     INSERT TEXT SYMBOL INTO DEFINITION IF NO MATCH
   70 KIND=3
   71 IF(MASTER(IADDRS).EQ.16)GO TO 83
      IF(N.EQ.3)GO TO 73
      IF(KIND.EQ.N)GO TO 72
      IF(N.GE.0)GO TO 73
      IF(KIND.EQ.3)GO TO 72
      IF(KIND.GE.0)GO TO 73
   72 MASTER(LEAST)=IBLANK
      LEAST=LEAST-1
   73 IF((LEAST-I+ILEFT-1).LE.MOST)GO TO 78
   74 MASTER(LEAST)=LETTER(ILEFT)
      LEAST=LEAST-1
      ILEFT=ILEFT+1
      IF(ILEFT.LE.I)GO TO 74
      GO TO 47
C
C     REVERSE TEXT WHEN COMPILATON DONE
   75 MASTER(NEW)=NEW-LEAST-1
      J=LEAST
   76 NEW=NEW-1
      J=J+1
      IF(NEW.LE.J)GO TO 77
      K=MASTER(NEW)
      MASTER(NEW)=MASTER(J)
      MASTER(J)=K
      GO TO 76
   77 MASTER(LEAST)=0
      MASTER(LSTNEW+1)=LEAST
      GO TO 82
C
C     PREPARE TO EXIT IF MASTER OVERFLOWS
   78 MASTER(IADDRS-1)=0
      LEAST=LSTNEW+1
      MASTER(LEAST)=0
      GO TO 84
C
C     *******************************
C     *  RETURN TO CALLING PROGRAM  *
C     *******************************
C
C     KODE IS RETURNED AS FOLLOWS
C     KODE   = 0, CALL TBLNXT.
C     KODE   = 1, ERROR DETECTED.
C     KODE   = 2, OVERFLOW OF STORAGE.
C
   79 IOPRTR=0
      GO TO 82
   80 KNTWRD=KNTWRD+1
      GO TO 82
   81 ISKIP=ISKIP-1
   82 KODE=0
      GO TO 85
   83 KODE=1
      GO TO 85
   84 KODE=2
   85 RETURN
      END