home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / fortran / toolpack.000 / toolpack / toolpack1.2 / tools / istrf / ISTRF.MAC.f
Encoding:
Text File  |  1989-03-04  |  80.0 KB  |  2,717 lines
  1. C---------------------------------------------------------
  2. C    TOOLPACK/1    Release: 2.5
  3. C---------------------------------------------------------
  4. C
  5. C  MAIN PROGRAM FOR TOOLPACK/IST TEXT FORMATTER: ISTRF
  6. C  WAYNE R. COWELL - ANL
  7. C  ROBERT M. J. ILES - NAG
  8. C
  9.       PROGRAM ISTRF
  10.  
  11.       INTEGER STATUS,FD,FDOPT,I
  12.       INTEGER SRCFIL(81),OUTFIL(81),MSG1(13),MSG2(14),
  13.      +        MSG3(14),OPTFIL(81)
  14.       INTEGER OPEN,GETARG,CREATE,ZGTCMD
  15. C---------------------------------------------------------
  16. C    TOOLPACK/1    Release: 2.5
  17. C---------------------------------------------------------
  18.       INTEGER CURPAG, NEWPAG, LINENO, PLVAL,  M1VAL, M2VAL,  M3VAL,
  19.      +        M4VAL,  BOTTOM, FRSTPG, LASTPG, PRINT, OFFSET, FDOUT,
  20.      +        NOWARN, FDSAVE
  21.       LOGICAL STOPH, STOPF, STOPP, NORMFD
  22.       INTEGER EHEAD(134), OHEAD(134), EHLIM(2), OHLIM(2),
  23.      +        EFOOT(134), OFOOT(134), EFLIM(2), OFLIM(2),
  24.      +        LINEXX(134), LINLIM(2)
  25.       COMMON /CPAGE/ CURPAG,NEWPAG,LINENO,PLVAL,M1VAL,M2VAL,M3VAL,M4VAL,
  26.      +               BOTTOM,STOPH,STOPF,STOPP,
  27.      +               FRSTPG,LASTPG,PRINT,OFFSET,FDOUT,FDSAVE,NORMFD,
  28.      +               EHEAD,OHEAD,EHLIM,OHLIM,
  29.      +               EFOOT,OFOOT,EFLIM,OFLIM,
  30.      +               LINEXX, LINLIM, NOWARN
  31. C---------------------------------------------------------
  32. C    TOOLPACK/1    Release: 2.5
  33. C---------------------------------------------------------
  34.       INTEGER FILL,  LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL, BOVAL,
  35.      +        CCHAR, BSVAL, RJUST, CUVAL
  36.       INTEGER TABS(400), TJUST(3), CHUBED(4), CHBBED(4)
  37.       LOGICAL EMBEDU, EMBEDB
  38.       COMMON /CPARAM/ FILL, LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL,
  39.      +                BOVAL, BSVAL, RJUST, CUVAL, TABS, TJUST, CCHAR,
  40.      +                EMBEDU,CHUBED,EMBEDB,CHBBED
  41.  
  42.       SAVE
  43.  
  44.       DATA (MSG1(FD),FD=1,13)/73,110,112,117,116,32,102,105,
  45.      +     108,101,58,32,129/
  46.       DATA (MSG2(FD),FD=1,14)/79,117,116,112,117,116,32,102,
  47.      +     105,108,101,58,32,129/
  48.       DATA (MSG3(FD),FD=1,14)/79,112,116,105,111,110,32,102,
  49.      +     105,108,101,58,32,129/
  50.  
  51. C  INITIALIZE FORMATTER
  52.       CALL ZINIT
  53.  
  54. C  OBTAIN THE NAME OF THE INPUT FILE AND OPEN IT IF NOT STANDARD INPUT
  55.       STATUS = GETARG(1,SRCFIL,81)
  56.  
  57. C  IF NAME IS NOT FOUND, REQUEST IT FROM THE USER
  58.       IF (STATUS.EQ.-100) THEN
  59.           CALL ZPRMPT(MSG1)
  60.           STATUS = ZGTCMD(SRCFIL,0)
  61.       END IF
  62.  
  63.       FD = OPEN(SRCFIL,0)
  64.  
  65. C  CHECK THAT THE FILE WAS OPENED SUCCESSFULLY
  66.       IF (FD.EQ.-1) CALL ERROR('RF: Unable To Open Input File.')
  67.  
  68. C OBTAIN THE NAME OF THE OUTPUT FILE AND CREATE IT IF NOT STANDARD
  69. C OUTPUT FILE DESCRIPTOR OF OUTPUT FILE IS IN COMMON CPAGE
  70.       STATUS = GETARG(2,OUTFIL,81)
  71.  
  72. C  IF NAME IS NOT FOUND, REQUEST IT FROM THE USER
  73.       IF (STATUS.EQ.-100) THEN
  74.           CALL ZPRMPT(MSG2)
  75.           STATUS = ZGTCMD(OUTFIL,0)
  76.       END IF
  77.  
  78.       FDOUT = CREATE(OUTFIL,1)
  79.  
  80. C  CHECK THAT THE FILE WAS OPENED SUCCESSFULLY
  81.       IF (FDOUT.EQ.-1) CALL ERROR('RF: Unable To Create Output File.')
  82.  
  83.       CALL FINIT
  84.       STATUS = GETARG(3,OPTFIL,81)
  85.       IF (STATUS.EQ.-100) THEN
  86.           CALL ZPRMPT(MSG3)
  87.           STATUS = ZGTCMD(OPTFIL,0)
  88.       END IF
  89.       IF (STATUS.GT.0) THEN
  90.         IF(OPTFIL(1) .NE. CCHAR) THEN
  91.           FDOPT = OPEN(OPTFIL,0)
  92.           IF (FDOPT.NE.-1) THEN
  93.               CALL MAINSB(FDOPT,.FALSE.)
  94.           ELSE
  95.               CALL CANT(OPTFIL)
  96.               CALL ERROR('[ISTRF Error Termination].')
  97.           END IF
  98.         ELSE
  99.           CALL COMAND(OPTFIL)
  100.         ENDIF
  101.       END IF
  102.  
  103.       DO 100 I = 4,10
  104.           STATUS = GETARG(I,OPTFIL,81)
  105.           IF (STATUS.NE.-100) THEN
  106.               IF (STATUS.GT.0) THEN
  107.                 IF(OPTFIL(1) .NE. CCHAR) THEN
  108.                   FDOPT = OPEN(OPTFIL,0)
  109.                   IF (FDOPT.NE.-1) THEN
  110.                       CALL MAINSB(FDOPT,.FALSE.)
  111.                   ELSE
  112.                       CALL CANT(OPTFIL)
  113.                       CALL ERROR('[ISTRF Error Termination].')
  114.                   END IF
  115.                 ELSE
  116.                   CALL COMAND(OPTFIL)
  117.                 ENDIF
  118.               END IF
  119.           END IF
  120.   100 CONTINUE
  121.  
  122. C  CALL FORMATTER
  123.       CALL MAINSB(FD,.TRUE.)
  124.  
  125. C  SAY FAREWELL
  126.       IF (NOWARN.EQ.0) THEN
  127.           CALL ZMESS('[ISTRF Normal Termination].',1)
  128.           CALL ZQUIT(-2)
  129.       ELSE
  130.           CALL ZMESS('[ISTRF Warnings Reported].',1)
  131.           CALL ZQUIT(-1002)
  132.       END IF
  133.  
  134.       END
  135. C------------------------------------------------
  136. C
  137. C  MAIN SUBROUTINE. READ IN LINES AND PROCESS THEM EITHER
  138. C  BY CALLING COMAND (COMMAND LINES) OR TEXT (NON-COMMAND LINES).
  139. C  HANDLE POPPING UP THE INCLUDE FILE STACK AS WELL.
  140. C
  141.       SUBROUTINE MAINSB(FD,ENDIS)
  142.  
  143.       LOGICAL FLAG,TERMIN,ENDIS
  144.       INTEGER FD,INBUF(400),NGETLN
  145. C---------------------------------------------------------
  146. C    TOOLPACK/1    Release: 2.5
  147. C---------------------------------------------------------
  148.       INTEGER CURPAG, NEWPAG, LINENO, PLVAL,  M1VAL, M2VAL,  M3VAL,
  149.      +        M4VAL,  BOTTOM, FRSTPG, LASTPG, PRINT, OFFSET, FDOUT,
  150.      +        NOWARN, FDSAVE
  151.       LOGICAL STOPH, STOPF, STOPP, NORMFD
  152.       INTEGER EHEAD(134), OHEAD(134), EHLIM(2), OHLIM(2),
  153.      +        EFOOT(134), OFOOT(134), EFLIM(2), OFLIM(2),
  154.      +        LINEXX(134), LINLIM(2)
  155.       COMMON /CPAGE/ CURPAG,NEWPAG,LINENO,PLVAL,M1VAL,M2VAL,M3VAL,M4VAL,
  156.      +               BOTTOM,STOPH,STOPF,STOPP,
  157.      +               FRSTPG,LASTPG,PRINT,OFFSET,FDOUT,FDSAVE,NORMFD,
  158.      +               EHEAD,OHEAD,EHLIM,OHLIM,
  159.      +               EFOOT,OFOOT,EFLIM,OFLIM,
  160.      +               LINEXX, LINLIM, NOWARN
  161. C---------------------------------------------------------
  162. C    TOOLPACK/1    Release: 2.5
  163. C---------------------------------------------------------
  164.       INTEGER INFILE(8)
  165.       INTEGER LEVEL
  166.       COMMON /RFIO/ INFILE, LEVEL
  167. C---------------------------------------------------------
  168. C    TOOLPACK/1    Release: 2.5
  169. C---------------------------------------------------------
  170.       INTEGER FILL,  LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL, BOVAL,
  171.      +        CCHAR, BSVAL, RJUST, CUVAL
  172.       INTEGER TABS(400), TJUST(3), CHUBED(4), CHBBED(4)
  173.       LOGICAL EMBEDU, EMBEDB
  174.       COMMON /CPARAM/ FILL, LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL,
  175.      +                BOVAL, BSVAL, RJUST, CUVAL, TABS, TJUST, CCHAR,
  176.      +                EMBEDU,CHUBED,EMBEDB,CHBBED
  177.  
  178. C---------------------------------------------------------
  179. C    TOOLPACK/1    Release: 2.5
  180. C---------------------------------------------------------
  181.       INTEGER OUTP, OUTW, OUTWDS
  182.       INTEGER OUTBUF(400)
  183.       LOGICAL ATEND, LEGEN
  184.       COMMON /COUT/ OUTP, OUTW, OUTWDS, OUTBUF, ATEND, LEGEN
  185.  
  186.       SAVE
  187.  
  188.       DATA FLAG/.TRUE./
  189.  
  190.       IF (FLAG) THEN
  191.           ATEND = .FALSE.
  192.           FLAG = .FALSE.
  193.       END IF
  194.       LEGEN = ENDIS
  195.  
  196.       INFILE(1) = FD
  197.       LEVEL = 1
  198.   100 CONTINUE
  199.  
  200.       IF (LEVEL.GT.0) THEN
  201.   200     CONTINUE
  202.           IF (NGETLN(INBUF,INFILE(LEVEL)).NE.-100) THEN
  203.               IF (INBUF(1).EQ.CCHAR) THEN
  204.                   CALL COMAND(INBUF)
  205.               ELSE
  206.                   CALL TEXT(INBUF)
  207.               END IF
  208.               GO TO 200
  209.           END IF
  210.           IF (LEVEL.GT.1 .AND. INFILE(LEVEL).GE.
  211.      +        0) CALL CLOSE(INFILE(LEVEL))
  212.           LEVEL = LEVEL - 1
  213.           GO TO 100
  214.       END IF
  215.  
  216.       CALL BRK
  217.       IF (PLVAL.LE.100 .AND. (LINENO.GT.0.OR.OUTP.GT.0))
  218.      +    CALL SPACE(20000)
  219.  
  220.       END
  221. C----------------------------------------
  222. C
  223. C  JUSTIFY UNPROCESSED TEXT ON A SINGLE LINE
  224. C
  225.       SUBROUTINE DOCL(LINE)
  226.  
  227.       INTEGER LINE(*)
  228.       INTEGER BUFFER(0:134),TEMP(134)
  229.       INTEGER GFIELD
  230.       INTEGER LENT,I,WIDTH,LEFT,RIGHT
  231. C---------------------------------------------------------
  232. C    TOOLPACK/1    Release: 2.5
  233. C---------------------------------------------------------
  234.       INTEGER FILL,  LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL, BOVAL,
  235.      +        CCHAR, BSVAL, RJUST, CUVAL
  236.       INTEGER TABS(400), TJUST(3), CHUBED(4), CHBBED(4)
  237.       LOGICAL EMBEDU, EMBEDB
  238.       COMMON /CPARAM/ FILL, LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL,
  239.      +                BOVAL, BSVAL, RJUST, CUVAL, TABS, TJUST, CCHAR,
  240.      +                EMBEDU,CHUBED,EMBEDB,CHBBED
  241.  
  242.       SAVE
  243.  
  244.       DO 100 I = 0,RMVAL
  245.           BUFFER(I) = 32
  246.   100 CONTINUE
  247.  
  248.       I = 1
  249.       WIDTH = RMVAL - INVAL + 1
  250.       LEFT = 1
  251.       RIGHT = RMVAL - INVAL + 1
  252.  
  253.       LENT = GFIELD(LINE,I,WIDTH,TEMP,LINE(1))
  254.       IF (LENT.GT.0) CALL JUSTFY(TEMP,LEFT,RIGHT,1,BUFFER)
  255.       LENT = GFIELD(LINE,I,WIDTH,TEMP,LINE(1))
  256.       IF (LENT.GT.0) CALL JUSTFY(TEMP,LEFT,RIGHT,2,BUFFER)
  257.       LENT = GFIELD(LINE,I,WIDTH,TEMP,LINE(1))
  258.       IF (LENT.GT.0) CALL JUSTFY(TEMP,LEFT,RIGHT,3,BUFFER)
  259.  
  260.       BUFFER(RMVAL+1) = 129
  261.  
  262.       CALL PUT(BUFFER)
  263.  
  264.       END
  265. C-----------------------------------------------------------------
  266. C
  267.       SUBROUTINE BOLD2(BUF,TBUF)
  268.  
  269.       INTEGER J
  270.       INTEGER BUF(*),TBUF(*)
  271.       INTEGER LENGTH
  272.  
  273.       TBUF(1) = -50
  274.       CALL SCOPY(BUF,1,TBUF,2)
  275.       J = LENGTH(TBUF)
  276.       IF (TBUF(J).NE.10) J = J + 1
  277.       TBUF(J) = -51
  278.       TBUF(J+1) = 10
  279.       TBUF(J+2) = 129
  280.       CALL SCOPY(TBUF,1,BUF,1)
  281.  
  282.       END
  283. C-----------------------------------------------------------------
  284. C
  285. C  BOLD A PIECE OF TEXT, USE TBUF AS A TEMPORARY BUFFER BUT
  286. C  RETURN THE EMBOLDENED TEXT IN 'BUF'.
  287. C  IF NORMAL BOLD IS BEING USED THEN OVERPRINT EACH CHARACTER
  288. C  WITH ITSELF (USING BACKSPACE), OTHERWISE JUST ADD THE
  289. C  TURN ON AND OFF COMMANDS....
  290. C
  291. C
  292.       SUBROUTINE BOLD(BUF,TBUF)
  293.  
  294.       INTEGER I,J
  295.       INTEGER BUF(*),TBUF(*)
  296.       INTEGER LENGTH
  297.  
  298. C---------------------------------------------------------
  299. C    TOOLPACK/1    Release: 2.5
  300. C---------------------------------------------------------
  301.       INTEGER FILL,  LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL, BOVAL,
  302.      +        CCHAR, BSVAL, RJUST, CUVAL
  303.       INTEGER TABS(400), TJUST(3), CHUBED(4), CHBBED(4)
  304.       LOGICAL EMBEDU, EMBEDB
  305.       COMMON /CPARAM/ FILL, LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL,
  306.      +                BOVAL, BSVAL, RJUST, CUVAL, TABS, TJUST, CCHAR,
  307.      +                EMBEDU,CHUBED,EMBEDB,CHBBED
  308.  
  309.       SAVE
  310.  
  311.       IF (EMBEDB) THEN
  312.           TBUF(1) = CHBBED(1)
  313.           TBUF(2) = CHBBED(2)
  314.           CALL SCOPY(BUF,1,TBUF,3)
  315.           J = LENGTH(TBUF)
  316.           IF (TBUF(J).NE.10) J = J + 1
  317.           TBUF(J) = CHBBED(3)
  318.           TBUF(J+1) = CHBBED(4)
  319.           TBUF(J+2) = 10
  320.           TBUF(J+3) = 129
  321.       ELSE
  322.  
  323.           J = 1
  324.           I = 1
  325.   100     CONTINUE
  326.           IF (BUF(I).NE.10) THEN
  327.               TBUF(J) = BUF(I)
  328.               J = J + 1
  329.               IF (BUF(I).NE.32 .AND. BUF(I).NE.9 .AND.
  330.      +            BUF(I).NE.8 .AND. BUF(I).NE.-20 .AND.
  331.      +            BUF(I).NE.-10 .AND. BUF(I).NE.-11) THEN
  332.  
  333.                   TBUF(J) = 8
  334.                   TBUF(J+1) = BUF(I)
  335.                   J = J + 2
  336.  
  337.               END IF
  338.               I = I + 1
  339.               GO TO 100
  340.           END IF
  341.           TBUF(J) = 10
  342.           TBUF(J+1) = 129
  343.  
  344.       END IF
  345.  
  346.       CALL SCOPY(TBUF,1,BUF,1)
  347.  
  348.       END
  349. C------------------------------------------------
  350.       SUBROUTINE BRK
  351.  
  352. C---------------------------------------------------------
  353. C    TOOLPACK/1    Release: 2.5
  354. C---------------------------------------------------------
  355.       INTEGER OUTP, OUTW, OUTWDS
  356.       INTEGER OUTBUF(400)
  357.       LOGICAL ATEND, LEGEN
  358.       COMMON /COUT/ OUTP, OUTW, OUTWDS, OUTBUF, ATEND, LEGEN
  359.  
  360.       SAVE
  361.  
  362.       IF (OUTP.GT.0) THEN
  363.           OUTBUF(OUTP) = 10
  364.           OUTBUF(OUTP+1) = 129
  365.           CALL PUT(OUTBUF)
  366.       END IF
  367.  
  368.       OUTP = 0
  369.       OUTW = 0
  370.       OUTWDS = 0
  371.  
  372.       END
  373. C------------------------------------------------
  374.       SUBROUTINE CENTER(BUF)
  375.  
  376.       INTEGER BUF(*)
  377.       INTEGER WIDTH
  378.       INTRINSIC MAX
  379. C---------------------------------------------------------
  380. C    TOOLPACK/1    Release: 2.5
  381. C---------------------------------------------------------
  382.       INTEGER FILL,  LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL, BOVAL,
  383.      +        CCHAR, BSVAL, RJUST, CUVAL
  384.       INTEGER TABS(400), TJUST(3), CHUBED(4), CHBBED(4)
  385.       LOGICAL EMBEDU, EMBEDB
  386.       COMMON /CPARAM/ FILL, LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL,
  387.      +                BOVAL, BSVAL, RJUST, CUVAL, TABS, TJUST, CCHAR,
  388.      +                EMBEDU,CHUBED,EMBEDB,CHBBED
  389.  
  390.       SAVE
  391.  
  392.       TIVAL = MAX((RMVAL+TIVAL-WIDTH(BUF))/2,0)
  393.  
  394.       END
  395. C------------------------------------------------
  396.       SUBROUTINE COMAND(BUF)
  397.  
  398.       INTEGER BUF(*),NAME(134),DEFN(400)
  399.       INTEGER COMTYP,GETVAL,GETWRD,OPEN,LENGTH,CREATE
  400.       INTEGER ARGTYP,CT,SPVAL,VAL,I,COMVAL,J
  401. C---------------------------------------------------------
  402. C    TOOLPACK/1    Release: 2.5
  403. C---------------------------------------------------------
  404.       INTEGER CURPAG, NEWPAG, LINENO, PLVAL,  M1VAL, M2VAL,  M3VAL,
  405.      +        M4VAL,  BOTTOM, FRSTPG, LASTPG, PRINT, OFFSET, FDOUT,
  406.      +        NOWARN, FDSAVE
  407.       LOGICAL STOPH, STOPF, STOPP, NORMFD
  408.       INTEGER EHEAD(134), OHEAD(134), EHLIM(2), OHLIM(2),
  409.      +        EFOOT(134), OFOOT(134), EFLIM(2), OFLIM(2),
  410.      +        LINEXX(134), LINLIM(2)
  411.       COMMON /CPAGE/ CURPAG,NEWPAG,LINENO,PLVAL,M1VAL,M2VAL,M3VAL,M4VAL,
  412.      +               BOTTOM,STOPH,STOPF,STOPP,
  413.      +               FRSTPG,LASTPG,PRINT,OFFSET,FDOUT,FDSAVE,NORMFD,
  414.      +               EHEAD,OHEAD,EHLIM,OHLIM,
  415.      +               EFOOT,OFOOT,EFLIM,OFLIM,
  416.      +               LINEXX, LINLIM, NOWARN
  417. C---------------------------------------------------------
  418. C    TOOLPACK/1    Release: 2.5
  419. C---------------------------------------------------------
  420.       INTEGER FILL,  LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL, BOVAL,
  421.      +        CCHAR, BSVAL, RJUST, CUVAL
  422.       INTEGER TABS(400), TJUST(3), CHUBED(4), CHBBED(4)
  423.       LOGICAL EMBEDU, EMBEDB
  424.       COMMON /CPARAM/ FILL, LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL,
  425.      +                BOVAL, BSVAL, RJUST, CUVAL, TABS, TJUST, CCHAR,
  426.      +                EMBEDU,CHUBED,EMBEDB,CHBBED
  427.  
  428. C---------------------------------------------------------
  429. C    TOOLPACK/1    Release: 2.5
  430. C---------------------------------------------------------
  431.       INTEGER INFILE(8)
  432.       INTEGER LEVEL
  433.       COMMON /RFIO/ INFILE, LEVEL
  434. C---------------------------------------------------------
  435. C    TOOLPACK/1    Release: 2.5
  436. C---------------------------------------------------------
  437.       INTEGER NR(52)
  438.       COMMON /CNR/ NR
  439.  
  440. C---------------------------------------------------------
  441. C    TOOLPACK/1    Release: 2.5
  442. C---------------------------------------------------------
  443.       LOGICAL BARFLG, ENDBAR, DELFLG
  444.       INTEGER BARCHR, DELCHR, FSCHAR
  445.       COMMON /CBAR/ BARFLG, BARCHR, DELFLG, ENDBAR, DELCHR, FSCHAR
  446.       SAVE
  447.  
  448.       CT = COMTYP(BUF,DEFN)
  449.       IF (CT.EQ.0) THEN
  450.           NOWARN = NOWARN + 1
  451.           CALL ZCHOUT('[ISTRF: WARNING - Unknown command: .',2)
  452.           CALL ZPTMES(BUF,2)
  453.       ELSE IF (CT.NE.51) THEN
  454.           CALL DOESC(BUF,NAME,132)
  455.  
  456.           I = 1
  457.   100     CONTINUE
  458.           IF (BUF(I).NE.32 .AND. BUF(I).NE.9 .AND.
  459.      +        BUF(I).NE.10 .AND. BUF(I) .NE. 129) THEN
  460.               I = I + 1
  461.               GO TO 100
  462.           END IF
  463.           VAL = GETVAL(BUF,I,ARGTYP)
  464.           IF (CT.EQ.36) THEN
  465.               COMVAL = GETVAL(BUF,I,ARGTYP)
  466.               IF (VAL.LT.COMVAL) THEN
  467.                   RETURN
  468.               ELSE
  469.                   CALL SKIPBL(BUF,I)
  470.                   J = I
  471.   200             CONTINUE
  472.                   IF (J.LE.132) THEN
  473.                       BUF(J-I+1) = BUF(J)
  474.                       J = J + 1
  475.                       GO TO 200
  476.                   END IF
  477.                   CT = COMTYP(BUF,DEFN)
  478.                   IF (CT.EQ.0) THEN
  479.                       RETURN
  480.                   ELSE
  481.                       I = 1
  482.   300                 CONTINUE
  483.                       IF (BUF(I).NE.32 .AND. BUF(I).NE.9 .AND.
  484.      +                    BUF(I).NE.10 .AND. BUF(I) .NE. 129) THEN
  485.                           I = I + 1
  486.                           GO TO 300
  487.                       END IF
  488.                       VAL = GETVAL(BUF,I,ARGTYP)
  489.                   END IF
  490.               END IF
  491.  
  492.           ELSE IF (CT.EQ.38) THEN
  493.               COMVAL = GETVAL(BUF,I,ARGTYP)
  494.               IF (VAL.NE.COMVAL) THEN
  495.                   RETURN
  496.               ELSE
  497.                   CALL SKIPBL(BUF,I)
  498.                   J = I
  499.   400             CONTINUE
  500.                   IF (J.LE.132) THEN
  501.                       BUF(J-I+1) = BUF(J)
  502.                       J = J + 1
  503.                       GO TO 400
  504.                   END IF
  505.                   CT = COMTYP(BUF,DEFN)
  506.                   IF (CT.EQ.0) THEN
  507.                       RETURN
  508.                   ELSE
  509.                       I = 1
  510.   500                 CONTINUE
  511.                       IF (BUF(I).NE.32 .AND. BUF(I).NE.9 .AND.
  512.      +                    BUF(I).NE.10 .AND. BUF(I) .NE. 129) THEN
  513.                           I = I + 1
  514.                           GO TO 500
  515.                       END IF
  516.  
  517.                       VAL = GETVAL(BUF,I,ARGTYP)
  518.                   END IF
  519.               END IF
  520.  
  521.           ELSE IF (CT.EQ.39) THEN
  522.               COMVAL = GETVAL(BUF,I,ARGTYP)
  523.               IF (VAL.GT.COMVAL) THEN
  524.                   RETURN
  525.               ELSE
  526.                   CALL SKIPBL(BUF,I)
  527.                   J = I
  528.   600             CONTINUE
  529.                   IF (J.LE.132) THEN
  530.                       BUF(J-I+1) = BUF(J)
  531.                       J = J + 1
  532.                       GO TO 600
  533.                   END IF
  534.                   CT = COMTYP(BUF,DEFN)
  535.                   IF (CT.EQ.0) THEN
  536.                       RETURN
  537.                   ELSE
  538.                       I = 1
  539.   700                 CONTINUE
  540.                       IF (BUF(I).NE.32 .AND. BUF(I).NE.9 .AND.
  541.      +                    BUF(I).NE.10 .AND. BUF(I) .NE. 129) THEN
  542.                           I = I + 1
  543.                           GO TO 700
  544.                       END IF
  545.  
  546.                       VAL = GETVAL(BUF,I,ARGTYP)
  547.                   END IF
  548.               END IF
  549.           END IF
  550.  
  551.           IF (CT.EQ.-1) THEN
  552.               CALL EVAL(BUF,DEFN)
  553.           ELSE IF (CT.EQ.37) THEN
  554.               CALL BRK
  555.               CALL GETTL(BUF,LINEXX,LINLIM)
  556.               CALL DOCL(LINEXX)
  557.           ELSE IF (CT.EQ.1) THEN
  558.               CALL BRK
  559.               FILL = -2
  560.           ELSE IF (CT.EQ.2) THEN
  561.               CALL BRK
  562.               FILL = -3
  563.           ELSE IF (CT.EQ.3) THEN
  564.               CALL BRK
  565.           ELSE IF (CT.EQ.4) THEN
  566.               CALL SET(LSVAL,VAL,ARGTYP,1,1,20000)
  567.           ELSE IF (CT.EQ.10) THEN
  568.               CALL BRK
  569.               CALL SET(CEVAL,VAL,ARGTYP,1,0,20000)
  570.           ELSE IF (CT.EQ.11) THEN
  571.               CUVAL = 0
  572.               CALL SET(ULVAL,VAL,ARGTYP,0,1,20000)
  573.           ELSE IF (CT.EQ.16) THEN
  574.               CALL SET(BOVAL,VAL,ARGTYP,0,1,20000)
  575.           ELSE IF (CT.EQ.12) THEN
  576.               CALL GETTL(BUF,EHEAD,EHLIM)
  577.               CALL GETTL(BUF,OHEAD,OHLIM)
  578.           ELSE IF (CT.EQ.13) THEN
  579.               CALL GETTL(BUF,EFOOT,EFLIM)
  580.               CALL GETTL(BUF,OFOOT,OFLIM)
  581.           ELSE IF (CT.EQ.5) THEN
  582.               CALL BRK
  583.               IF (LINENO.GT.0) CALL SPACE(20000)
  584.               CALL SET(CURPAG,VAL,ARGTYP,CURPAG+1,-20000,20000)
  585.               NEWPAG = CURPAG
  586.           ELSE IF (CT.EQ.6) THEN
  587.               CALL SET(SPVAL,VAL,ARGTYP,1,0,20000)
  588.               CALL SPACE(SPVAL)
  589.           ELSE IF (CT.EQ.7) THEN
  590.               CALL BRK
  591.               CALL SET(INVAL,VAL,ARGTYP,0,0,RMVAL-1)
  592.               TIVAL = INVAL
  593.               NR(51) = INVAL
  594.           ELSE IF (CT.EQ.8) THEN
  595.               CALL SET(RMVAL,VAL,ARGTYP,65,TIVAL+1,20000)
  596.           ELSE IF (CT.EQ.9) THEN
  597.               CALL BRK
  598.               CALL SET(TIVAL,VAL,ARGTYP,0,0,RMVAL)
  599.           ELSE IF (CT.EQ.14) THEN
  600.               CALL SET(PLVAL,VAL,ARGTYP,66,
  601.      +                 M1VAL+M2VAL+M3VAL+M4VAL+1,20000)
  602.               BOTTOM = PLVAL - M3VAL - M4VAL
  603.           ELSE IF (CT.EQ.15) THEN
  604.               CALL SET(OFFSET,VAL,ARGTYP,0,0,RMVAL-1)
  605.           ELSE IF (CT.EQ.17) THEN
  606.               CALL SET(M1VAL,VAL,ARGTYP,3,0,PLVAL-M2VAL-M3VAL-M4VAL-1)
  607.           ELSE IF (CT.EQ.18) THEN
  608.               CALL SET(M2VAL,VAL,ARGTYP,2,0,PLVAL-M1VAL-M3VAL-M4VAL-1)
  609.           ELSE IF (CT.EQ.19) THEN
  610.               CALL SET(M3VAL,VAL,ARGTYP,2,0,PLVAL-M1VAL-M2VAL-M4VAL-1)
  611.               BOTTOM = PLVAL - M3VAL - M4VAL
  612.           ELSE IF (CT.EQ.20) THEN
  613.               CALL SET(M4VAL,VAL,ARGTYP,3,0,PLVAL-M1VAL-M2VAL-M3VAL-1)
  614.               BOTTOM = PLVAL - M3VAL - M4VAL
  615.           ELSE
  616.               GO TO 800
  617.           END IF
  618.           RETURN
  619. C
  620. C  AVOID THE IBM LIMIT OF 25 ELSE-IF BLOCKS
  621. C
  622.  800      IF (CT.EQ.21) THEN
  623.               CALL GETTL(BUF,EHEAD,EHLIM)
  624.           ELSE IF (CT.EQ.22) THEN
  625.               CALL GETTL(BUF,OHEAD,OHLIM)
  626.           ELSE IF (CT.EQ.23) THEN
  627.               CALL GETTL(BUF,EFOOT,EFLIM)
  628.           ELSE IF (CT.EQ.24) THEN
  629.               CALL GETTL(BUF,OFOOT,OFLIM)
  630.           ELSE IF (CT.EQ.25) THEN
  631.               CCHAR = ARGTYP
  632.               IF (CCHAR.EQ.129 .OR. CCHAR.EQ.10) CCHAR = 46
  633.               IF ((LINENO+VAL).GT.BOTTOM .AND.
  634.      +            LINENO.LE.BOTTOM) THEN
  635.                   CALL SPACE(VAL)
  636.                   LINENO = 0
  637.               END IF
  638.           ELSE IF (CT.EQ.26) THEN
  639.               IF ((LINENO+VAL).GT.BOTTOM .AND.
  640.      +            LINENO.LE.BOTTOM) THEN
  641.                   CALL SPACE(VAL)
  642.                   LINENO = 0
  643.               END IF
  644.           ELSE IF (CT.EQ.27) THEN
  645.               CALL SET(BSVAL,VAL,ARGTYP,1,0,20000)
  646.           ELSE IF (CT.EQ.28) THEN
  647.               RJUST = -2
  648.           ELSE IF (CT.EQ.29) THEN
  649.               RJUST = -3
  650.           ELSE IF (CT.EQ.30) THEN
  651.               IF (GETWRD(BUF,I,NAME).NE.0) THEN
  652.                   IF (LEVEL+1.GT.8) CALL REMARK(
  653.      +                'RF: SO REQUESTS NESTED TOO DEEPLY (COMAND).')
  654.                   INFILE(LEVEL+1) = OPEN(NAME,0)
  655.                   IF (INFILE(LEVEL+1).NE.-1) LEVEL = LEVEL + 1
  656.               END IF
  657.           ELSE IF (CT.EQ.31) THEN
  658.               ULVAL = 0
  659.               CALL SET(CUVAL,VAL,ARGTYP,0,1,20000)
  660.           ELSE IF (CT.EQ.32) THEN
  661.               CALL DODEF(BUF,INFILE(LEVEL))
  662.           ELSE IF (CT.EQ.34) THEN
  663.               IF (GETWRD(BUF,I,NAME).NE.0) THEN
  664.                   IF (NAME(1).LT.65 .OR.
  665.      +                (NAME(1).GT.90.AND.NAME(1).LT.97) .OR.
  666.      +                NAME(1).GT.122) CALL REMARK
  667.      +                ('RF: INVALID NUMBER REGISTER NAME (COMAND).')
  668.                   VAL = GETVAL(BUF,I,ARGTYP)
  669.                   IF (NAME(1).GE.97 .AND. NAME(1).LE.122) THEN
  670.                       CALL SET(NR(NAME(1)-97+1),VAL,ARGTYP,0,
  671.      +                         -20000,20000)
  672.                   ELSE
  673.                       CALL SET(NR(NAME(1)-65+27),VAL,ARGTYP,0,
  674.      +                         -20000,20000)
  675.                   END IF
  676.               END IF
  677.           ELSE IF (CT.EQ.35) THEN
  678.               IF (ARGTYP.EQ.45) THEN
  679.                   SPVAL = PLVAL
  680.               ELSE
  681.                   SPVAL = 0
  682.               END IF
  683.               CALL SET(SPVAL,VAL,ARGTYP,0,1,BOTTOM)
  684.               IF (SPVAL.GT.LINENO .AND. LINENO.EQ.0) CALL PHEAD
  685.               IF (SPVAL.GT.LINENO) CALL SPACE(SPVAL-LINENO)
  686.           ELSE IF (CT.EQ.40) THEN
  687.               IF (.NOT.BARFLG) THEN
  688.                   BARFLG = .TRUE.
  689.                   ENDBAR = .FALSE.
  690.               END IF
  691.           ELSE IF (CT.EQ.44) THEN
  692.               DELFLG = .TRUE.
  693.           ELSE IF (CT.EQ.41) THEN
  694.               ENDBAR = .TRUE.
  695.           ELSE IF (CT.EQ.42) THEN
  696.               BARCHR = ARGTYP
  697.               IF (BARCHR.EQ.129 .OR. BARCHR.EQ.10) BARCHR = 124
  698.           ELSE IF (CT.EQ.43) THEN
  699.               DELCHR = ARGTYP
  700.               IF (DELCHR.EQ.129 .OR. DELCHR.EQ.
  701.      +            10) DELCHR = 35
  702.           ELSE IF (CT.EQ.45) THEN
  703.               FSCHAR = ARGTYP
  704.               IF (FSCHAR.EQ.129 .OR. FSCHAR.EQ.
  705.      +            10) FSCHAR = 126
  706.           ELSE IF (CT.EQ.46) THEN
  707.               STOPF = .NOT. STOPF
  708.               IF(ARGTYP .EQ. 45) STOPP = .FALSE.
  709.               IF(ARGTYP .EQ.  43) STOPP = .TRUE.
  710.           ELSE IF (CT.EQ.52) THEN
  711.               STOPH = .NOT. STOPH
  712.               IF(ARGTYP .EQ. 45) STOPP = .FALSE.
  713.               IF(ARGTYP .EQ.  43) STOPP = .TRUE.
  714.           ELSE
  715.               GO TO 900
  716.           END IF
  717.           RETURN
  718. C
  719. C  AVOID THE IBM LIMIT OF 25 ELSE-IF BLOCKS
  720. C
  721.  900      IF (CT.EQ.50) THEN
  722.               EMBEDB = .TRUE.
  723.               CALL SKIPBL(BUF,I)
  724.               IF (I.NE.129 .AND. LENGTH(BUF).GE.I+3) THEN
  725.                   CHBBED(1) = BUF(I)
  726.                   CHBBED(2) = BUF(I+1)
  727.                   CHBBED(3) = BUF(I+2)
  728.                   CHBBED(4) = BUF(I+3)
  729.               END IF
  730.           ELSE IF (CT.EQ.48) THEN
  731.               EMBEDB = .FALSE.
  732.           ELSE IF (CT.EQ.49) THEN
  733.               EMBEDU = .TRUE.
  734.               CALL SKIPBL(BUF,I)
  735.               IF (I.NE.129 .AND. LENGTH(BUF).GE.I+3) THEN
  736.                   CHUBED(1) = BUF(I)
  737.                   CHUBED(2) = BUF(I+1)
  738.                   CHUBED(3) = BUF(I+2)
  739.                   CHUBED(4) = BUF(I+3)
  740.               END IF
  741.           ELSE IF (CT.EQ.47) THEN
  742.               EMBEDU = .FALSE.
  743.           ELSE IF (CT.EQ.53) THEN
  744.               CALL BRK
  745.               IF(.NOT. NORMFD) THEN
  746.                 NORMFD = .TRUE.
  747.                 CALL CLOSE(FDOUT)
  748.               ELSE
  749.                 FDSAVE = FDOUT
  750.               ENDIF
  751.  
  752.               FDOUT = -1
  753.               IF (GETWRD(BUF,I,NAME).NE.0) FDOUT = CREATE(NAME,1)
  754.               IF(FDOUT .NE. -1) THEN
  755.                 NORMFD = .FALSE.
  756.               ELSE
  757.                 CALL CANT(NAME)
  758.                 CALL ERROR('[ISTRF: Error Termination].')
  759.               ENDIF
  760.           ELSE IF (CT.EQ.54) THEN
  761.               CALL BRK
  762.               IF(.NOT. NORMFD) THEN
  763.                 NORMFD = .TRUE.
  764.                 CALL CLOSE(FDOUT)
  765.                 FDOUT = FDSAVE
  766.               ENDIF
  767.           END IF
  768.       END IF
  769.  
  770.       END
  771. C------------------------------------------------
  772.       INTEGER FUNCTION COMTYP(BUF,DEFN)
  773.  
  774.       INTEGER BUF(*),DEFN(*)
  775.  
  776.       INTEGER NAME(13),MAXCMD
  777.       PARAMETER (MAXCMD=54)
  778.       INTEGER I,GETWRD,VALUES(3,MAXCMD)
  779.       LOGICAL LUDEF
  780.       SAVE VALUES
  781.  
  782.       DATA (VALUES(I,1),I=1,3)/115,112,6/
  783.       DATA (VALUES(I,2),I=1,3)/110,102,2/
  784.       DATA (VALUES(I,3),I=1,3)/98,114,3/
  785.       DATA (VALUES(I,4),I=1,3)/108,115,4/
  786.       DATA (VALUES(I,5),I=1,3)/98,112,5/
  787.       DATA (VALUES(I,6),I=1,3)/102,105,1/
  788.       DATA (VALUES(I,7),I=1,3)/105,110,7/
  789.       DATA (VALUES(I,8),I=1,3)/114,109,8/
  790.       DATA (VALUES(I,9),I=1,3)/116,105,9/
  791.       DATA (VALUES(I,10),I=1,3)/99,101,10/
  792.       DATA (VALUES(I,11),I=1,3)/99,108,37/
  793.       DATA (VALUES(I,12),I=1,3)/117,108,11/
  794.       DATA (VALUES(I,13),I=1,3)/104,101,12/
  795.       DATA (VALUES(I,14),I=1,3)/102,111,13/
  796.       DATA (VALUES(I,15),I=1,3)/112,108,14/
  797.       DATA (VALUES(I,16),I=1,3)/112,111,15/
  798.       DATA (VALUES(I,17),I=1,3)/98,100,16/
  799.       DATA (VALUES(I,18),I=1,3)/109,49,17/
  800.       DATA (VALUES(I,19),I=1,3)/109,50,18/
  801.       DATA (VALUES(I,20),I=1,3)/109,51,19/
  802.       DATA (VALUES(I,21),I=1,3)/109,52,20/
  803.       DATA (VALUES(I,22),I=1,3)/101,104,21/
  804.       DATA (VALUES(I,23),I=1,3)/111,104,22/
  805.       DATA (VALUES(I,24),I=1,3)/101,102,23/
  806.       DATA (VALUES(I,25),I=1,3)/111,102,24/
  807.       DATA (VALUES(I,26),I=1,3)/99,99,25/
  808.       DATA (VALUES(I,27),I=1,3)/110,101,26/
  809.       DATA (VALUES(I,28),I=1,3)/98,115,27/
  810.       DATA (VALUES(I,29),I=1,3)/106,117,28/
  811.       DATA (VALUES(I,30),I=1,3)/110,106,29/
  812.       DATA (VALUES(I,31),I=1,3)/115,111,30/
  813.       DATA (VALUES(I,32),I=1,3)/99,117,31/
  814.       DATA (VALUES(I,33),I=1,3)/100,101,32/
  815.       DATA (VALUES(I,34),I=1,3)/101,110,33/
  816.       DATA (VALUES(I,35),I=1,3)/110,114,34/
  817.       DATA (VALUES(I,36),I=1,3)/115,116,35/
  818.       DATA (VALUES(I,37),I=1,3)/105,102,36/
  819.       DATA (VALUES(I,38),I=1,3)/105,101,38/
  820.       DATA (VALUES(I,39),I=1,3)/105,108,39/
  821.       DATA (VALUES(I,40),I=1,3)/98,98,40/
  822.       DATA (VALUES(I,41),I=1,3)/101,98,41/
  823.       DATA (VALUES(I,42),I=1,3)/98,99,42/
  824.       DATA (VALUES(I,43),I=1,3)/100,98,44/
  825.       DATA (VALUES(I,44),I=1,3)/100,99,43/
  826.       DATA (VALUES(I,45),I=1,3)/102,115,45/
  827.       DATA (VALUES(I,46),I=1,3)/112,102,46/
  828.       DATA (VALUES(I,47),I=1,3)/110,117,47/
  829.       DATA (VALUES(I,48),I=1,3)/110,98,48/
  830.       DATA (VALUES(I,49),I=1,3)/105,117,49/
  831.       DATA (VALUES(I,50),I=1,3)/105,98,50/
  832.       DATA (VALUES(I,51),I=1,3)/110,111,51/
  833.       DATA (VALUES(I,52),I=1,3)/112,104,52/
  834.       DATA (VALUES(I,53),I=1,3)/115,102,53/
  835.       DATA (VALUES(I,54),I=1,3)/122,102,54/
  836.  
  837.       I = 2
  838.       I = GETWRD(BUF,I,NAME)
  839.       IF (I.GT.2) NAME(3) = 129
  840.  
  841.       IF (LUDEF(NAME,DEFN)) THEN
  842.           COMTYP = -1
  843.       ELSE
  844.           COMTYP = 0
  845.           DO 100 I = 1,MAXCMD
  846.               IF (BUF(2).EQ.VALUES(1,I) .AND.
  847.      +            BUF(3).EQ.VALUES(2,I)) GO TO 200
  848.   100     CONTINUE
  849.           RETURN
  850.   200     COMTYP = VALUES(3,I)
  851.       END IF
  852.  
  853.       END
  854. C------------------------------------------------
  855.       SUBROUTINE DODEF(BUF,FD)
  856.  
  857.       INTEGER BUF(*)
  858.       INTEGER FD
  859.       INTEGER NAME(13),DEFN(400)
  860.       INTEGER I,JUNK
  861.       INTEGER GETWRD,ADDSTR,ADDSET,NGETLN
  862.  
  863. C---------------------------------------------------------
  864. C    TOOLPACK/1    Release: 2.5
  865. C---------------------------------------------------------
  866.       INTEGER FILL,  LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL, BOVAL,
  867.      +        CCHAR, BSVAL, RJUST, CUVAL
  868.       INTEGER TABS(400), TJUST(3), CHUBED(4), CHBBED(4)
  869.       LOGICAL EMBEDU, EMBEDB
  870.       COMMON /CPARAM/ FILL, LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL,
  871.      +                BOVAL, BSVAL, RJUST, CUVAL, TABS, TJUST, CCHAR,
  872.      +                EMBEDU,CHUBED,EMBEDB,CHBBED
  873.  
  874.       SAVE
  875.  
  876.       I = 1
  877.       JUNK = GETWRD(BUF,I,NAME)
  878.       I = GETWRD(BUF,I,NAME)
  879.       IF (I.EQ.0) CALL REMARK(
  880.      +                 'RF: MISSING NAME IN REQUEST DEFINITION (DODEF).'
  881.      +                        )
  882.       IF (I.GT.2) NAME(3) = 129
  883.  
  884.       I = 1
  885.   100 CONTINUE
  886.       IF (NGETLN(BUF,FD).NE.-100) THEN
  887.           IF (BUF(1).NE.CCHAR .OR. BUF(2).NE.101 .OR.
  888.      +        BUF(3).NE.110) THEN
  889.               JUNK = ADDSTR(BUF,DEFN,I,400)
  890.               GO TO 100
  891.           END IF
  892.       END IF
  893.  
  894.       IF (ADDSET(129,DEFN,I,400).EQ.-3)
  895.      +    CALL REMARK('RF: DEFINITION TOO LONG (DODEF).')
  896.       CALL ENTDEF(NAME,DEFN)
  897.  
  898.       END
  899. C------------------------------------------------
  900.       SUBROUTINE DOESC(BUF,TBUF,SIZE)
  901.  
  902.       INTEGER BUF(*),TBUF(*)
  903.       INTEGER SIZE,ITOA
  904.       INTEGER I,J
  905.       INTEGER ITOC
  906.  
  907. C---------------------------------------------------------
  908. C    TOOLPACK/1    Release: 2.5
  909. C---------------------------------------------------------
  910.       LOGICAL BARFLG, ENDBAR, DELFLG
  911.       INTEGER BARCHR, DELCHR, FSCHAR
  912.       COMMON /CBAR/ BARFLG, BARCHR, DELFLG, ENDBAR, DELCHR, FSCHAR
  913. C---------------------------------------------------------
  914. C    TOOLPACK/1    Release: 2.5
  915. C---------------------------------------------------------
  916.       INTEGER NR(52)
  917.       COMMON /CNR/ NR
  918.  
  919.       SAVE
  920.  
  921.       J = 1
  922.       I = 1
  923.   100 CONTINUE
  924.  
  925.       IF (BUF(I).NE.129 .AND. J.LT.SIZE) THEN
  926.           IF (BUF(I).NE.64) THEN
  927.               IF (BUF(I).EQ.FSCHAR) THEN
  928.                   TBUF(J) = -20
  929.               ELSE
  930.                   TBUF(J) = BUF(I)
  931.               END IF
  932.               J = J + 1
  933.  
  934.           ELSE IF (BUF(I+1).EQ.64) THEN
  935.               TBUF(J) = 64
  936.               J = J + 1
  937.               I = I + 1
  938.  
  939.           ELSE IF (BUF(I+1).EQ.110 .AND.
  940.      +             ((BUF(I+2).GE.97.AND.BUF(I+2).LE.122).OR.
  941.      +             (BUF(I+2).GE.65.AND.BUF(I+2).LE.90))) THEN
  942.               IF (BUF(I+2).GE.97 .AND. BUF(I+2).LE.122) THEN
  943.                   J = J + ITOC(NR(BUF(I+2)-97+1),TBUF(J),SIZE-J-1)
  944.               ELSE
  945.                   J = J + ITOC(NR(BUF(I+2)-65+27),TBUF(J),SIZE-J-1)
  946.               END IF
  947.               I = I + 2
  948.  
  949.           ELSE IF (BUF(I+1).EQ.97 .AND.
  950.      +             ((BUF(I+2).GE.97.AND.BUF(I+2).LE.122).OR.
  951.      +             (BUF(I+2).GE.65.AND.BUF(I+2).LE.90))) THEN
  952.               IF (BUF(I+2).GE.97 .AND. BUF(I+2).LE.122) THEN
  953.                   J = J + ITOA(NR(BUF(I+2)-97+1),TBUF(J))
  954.               ELSE
  955.                   J = J + ITOA(NR(BUF(I+2)-65+27),TBUF(J))
  956.               END IF
  957.               I = I + 2
  958.  
  959.           ELSE IF (BUF(I+1).EQ.FSCHAR) THEN
  960.               TBUF(J) = FSCHAR
  961.               J = J + 1
  962.               I = I + 1
  963.           ELSE
  964.  
  965.               TBUF(J) = BUF(I)
  966.               J = J + 1
  967.  
  968.           END IF
  969.  
  970.           I = I + 1
  971.           GO TO 100
  972.       END IF
  973.  
  974.       TBUF(J) = 129
  975.       CALL SCOPY(TBUF,1,BUF,1)
  976.  
  977.       END
  978. C------------------------------------------------
  979.       SUBROUTINE DOTABS(BUF,TBUF,SIZE)
  980.  
  981.       INTEGER BUF(*),TBUF(*)
  982.       INTEGER SIZE
  983.       INTEGER I,J
  984.  
  985. C---------------------------------------------------------
  986. C    TOOLPACK/1    Release: 2.5
  987. C---------------------------------------------------------
  988.       INTEGER FILL,  LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL, BOVAL,
  989.      +        CCHAR, BSVAL, RJUST, CUVAL
  990.       INTEGER TABS(400), TJUST(3), CHUBED(4), CHBBED(4)
  991.       LOGICAL EMBEDU, EMBEDB
  992.       COMMON /CPARAM/ FILL, LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL,
  993.      +                BOVAL, BSVAL, RJUST, CUVAL, TABS, TJUST, CCHAR,
  994.      +                EMBEDU,CHUBED,EMBEDB,CHBBED
  995.  
  996.       SAVE
  997.  
  998.       J = 1
  999.       I = 1
  1000.   100 CONTINUE
  1001.       IF (BUF(I).NE.129 .AND. J.LT.SIZE) THEN
  1002.           IF (BUF(I).EQ.9) THEN
  1003.   200         CONTINUE
  1004.               IF (J.LT.SIZE) THEN
  1005.                   TBUF(J) = 32
  1006.                   J = J + 1
  1007.                   IF (TABS(J).NE.-2.AND.J.LE.400) GO TO 200
  1008.               END IF
  1009.           ELSE
  1010.               TBUF(J) = BUF(I)
  1011.               J = J + 1
  1012.           END IF
  1013.           I = I + 1
  1014.           GO TO 100
  1015.       END IF
  1016.  
  1017.       TBUF(J) = 129
  1018.       CALL SCOPY(TBUF,1,BUF,1)
  1019.  
  1020.       END
  1021. C------------------------------------------------
  1022.       SUBROUTINE EVAL(BUF,DEFN)
  1023.  
  1024.       INTEGER BUF(*),DEFN(*)
  1025.       INTEGER I,J,K,ARGPTR(10)
  1026.       INTEGER LENGTH
  1027.  
  1028.       DO 100 J = 1,10
  1029.           ARGPTR(J) = 1
  1030.   100 CONTINUE
  1031.  
  1032.       BUF(1) = 129
  1033.       I = 2
  1034.       DO 400 J = 1,10
  1035.           CALL SKIPBL(BUF,I)
  1036.           IF (BUF(I).EQ.10 .OR. BUF(I).EQ.129) THEN
  1037.               GO TO 600
  1038.           ELSE
  1039.               ARGPTR(J) = I
  1040.               IF (BUF(I).EQ.34) THEN
  1041.                   ARGPTR(J) = ARGPTR(J) + 1
  1042.                   I = I + 1
  1043.   200             CONTINUE
  1044.                   IF (BUF(I).NE.34) THEN
  1045.                       IF (BUF(I).EQ.10 .OR. BUF(I).EQ.129) THEN
  1046.                           GO TO 500
  1047.                       ELSE
  1048.                           I = I + 1
  1049.                           GO TO 200
  1050.                       END IF
  1051.                   END IF
  1052.               ELSE
  1053.   300             CONTINUE
  1054.  
  1055.                   IF (BUF(I).NE.32 .AND. BUF(I).NE.9 .AND.
  1056.      +                BUF(I).NE.10 .AND. BUF(I).NE.129) THEN
  1057.                       I = I + 1
  1058.                       GO TO 300
  1059.                   END IF
  1060.               END IF
  1061.  
  1062.               BUF(I) = 129
  1063.               I = I + 1
  1064.           END IF
  1065.   400 CONTINUE
  1066.  
  1067.       GO TO 600
  1068.   500 CALL REMARK('RF: MISSING DOUBLE QUOTE (EVAL).')
  1069.       RETURN
  1070.  
  1071.   600 CONTINUE
  1072.       K = LENGTH(DEFN)
  1073.   700 CONTINUE
  1074.       IF (K.GT.1) THEN
  1075.           IF (DEFN(K-1).NE.36) THEN
  1076.               CALL PUTBAK(DEFN(K))
  1077.           ELSE IF (DEFN(K).LT.48 .OR. DEFN(K).GT.57) THEN
  1078.               CALL PUTBAK(DEFN(K))
  1079.           ELSE
  1080.               I = DEFN(K) - 48 + 1
  1081.               I = ARGPTR(I)
  1082.               CALL PBSTR(BUF(I))
  1083.               K = K - 1
  1084.           END IF
  1085.           K = K - 1
  1086.           GO TO 700
  1087.       END IF
  1088.  
  1089.       IF (K.GT.0) CALL PUTBAK(DEFN(K))
  1090.  
  1091.       END
  1092. C------------------------------------------------
  1093. C
  1094.       SUBROUTINE FINIT
  1095.  
  1096.       INTEGER I
  1097.       INTRINSIC MOD
  1098. C---------------------------------------------------------
  1099. C    TOOLPACK/1    Release: 2.5
  1100. C---------------------------------------------------------
  1101.       INTEGER FILL,  LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL, BOVAL,
  1102.      +        CCHAR, BSVAL, RJUST, CUVAL
  1103.       INTEGER TABS(400), TJUST(3), CHUBED(4), CHBBED(4)
  1104.       LOGICAL EMBEDU, EMBEDB
  1105.       COMMON /CPARAM/ FILL, LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL,
  1106.      +                BOVAL, BSVAL, RJUST, CUVAL, TABS, TJUST, CCHAR,
  1107.      +                EMBEDU,CHUBED,EMBEDB,CHBBED
  1108.  
  1109. C---------------------------------------------------------
  1110. C    TOOLPACK/1    Release: 2.5
  1111. C---------------------------------------------------------
  1112.       INTEGER CURPAG, NEWPAG, LINENO, PLVAL,  M1VAL, M2VAL,  M3VAL,
  1113.      +        M4VAL,  BOTTOM, FRSTPG, LASTPG, PRINT, OFFSET, FDOUT,
  1114.      +        NOWARN, FDSAVE
  1115.       LOGICAL STOPH, STOPF, STOPP, NORMFD
  1116.       INTEGER EHEAD(134), OHEAD(134), EHLIM(2), OHLIM(2),
  1117.      +        EFOOT(134), OFOOT(134), EFLIM(2), OFLIM(2),
  1118.      +        LINEXX(134), LINLIM(2)
  1119.       COMMON /CPAGE/ CURPAG,NEWPAG,LINENO,PLVAL,M1VAL,M2VAL,M3VAL,M4VAL,
  1120.      +               BOTTOM,STOPH,STOPF,STOPP,
  1121.      +               FRSTPG,LASTPG,PRINT,OFFSET,FDOUT,FDSAVE,NORMFD,
  1122.      +               EHEAD,OHEAD,EHLIM,OHLIM,
  1123.      +               EFOOT,OFOOT,EFLIM,OFLIM,
  1124.      +               LINEXX, LINLIM, NOWARN
  1125. C---------------------------------------------------------
  1126. C    TOOLPACK/1    Release: 2.5
  1127. C---------------------------------------------------------
  1128.       INTEGER OUTP, OUTW, OUTWDS
  1129.       INTEGER OUTBUF(400)
  1130.       LOGICAL ATEND, LEGEN
  1131.       COMMON /COUT/ OUTP, OUTW, OUTWDS, OUTBUF, ATEND, LEGEN
  1132.  
  1133. C---------------------------------------------------------
  1134. C    TOOLPACK/1    Release: 2.5
  1135. C---------------------------------------------------------
  1136.       INTEGER BP
  1137.       INTEGER BUF(400)
  1138.       COMMON /CDEFIO/ BP, BUF
  1139.  
  1140. C---------------------------------------------------------
  1141. C    TOOLPACK/1    Release: 2.5
  1142. C---------------------------------------------------------
  1143.       INTEGER NR(52)
  1144.       COMMON /CNR/ NR
  1145.  
  1146. C---------------------------------------------------------
  1147. C    TOOLPACK/1    Release: 2.5
  1148. C---------------------------------------------------------
  1149.       LOGICAL BARFLG, ENDBAR, DELFLG
  1150.       INTEGER BARCHR, DELCHR, FSCHAR
  1151.       COMMON /CBAR/ BARFLG, BARCHR, DELFLG, ENDBAR, DELCHR, FSCHAR
  1152.       SAVE
  1153.  
  1154.       INVAL = 0
  1155.       RMVAL = 65
  1156.       TIVAL = 0
  1157.       LSVAL = 1
  1158.       FILL = -2
  1159.       CEVAL = 0
  1160.       ULVAL = 0
  1161.       BOVAL = 0
  1162.       CCHAR = 46
  1163.       TJUST(1) = 1
  1164.       TJUST(2) = 2
  1165.       TJUST(3) = 3
  1166.       BSVAL = 0
  1167.       RJUST = -2
  1168.       CUVAL = 0
  1169.       DO 100 I = 1,400
  1170.           IF (MOD(I,8).EQ.1) THEN
  1171.               TABS(I) = -2
  1172.           ELSE
  1173.               TABS(I) = -3
  1174.           END IF
  1175.   100 CONTINUE
  1176.  
  1177.       NORMFD = .TRUE.
  1178.       ENDBAR = .FALSE.
  1179.       DELFLG = .FALSE.
  1180.       BARFLG = .FALSE.
  1181.       BARCHR = 124
  1182.       DELCHR = 35
  1183.       FSCHAR = 126
  1184.       LINENO = 0
  1185.       CURPAG = 0
  1186.       NEWPAG = 1
  1187.       PLVAL = 66
  1188.       M1VAL = 3
  1189.       M2VAL = 2
  1190.       M3VAL = 2
  1191.       M4VAL = 3
  1192.       BOTTOM = PLVAL - M3VAL - M4VAL
  1193.       EHEAD(1) = 10
  1194.       EHEAD(2) = 129
  1195.       OHEAD(1) = 10
  1196.       OHEAD(2) = 129
  1197.       EFOOT(1) = 10
  1198.       EFOOT(2) = 129
  1199.       OFOOT(1) = 10
  1200.       OFOOT(2) = 129
  1201.       EHLIM(1) = INVAL
  1202.       EHLIM(2) = RMVAL
  1203.       OHLIM(1) = INVAL
  1204.       OHLIM(2) = RMVAL
  1205.       EFLIM(1) = INVAL
  1206.       EFLIM(2) = RMVAL
  1207.       OFLIM(1) = INVAL
  1208.       OFLIM(2) = RMVAL
  1209.       STOPH = .FALSE.
  1210.       STOPF = .FALSE.
  1211.       STOPP = .TRUE.
  1212.       FRSTPG = 0
  1213.       LASTPG = 20000
  1214.       PRINT = -2
  1215.       OFFSET = 0
  1216.       OUTP = 0
  1217.       OUTW = 0
  1218.       OUTWDS = 0
  1219.       CALL DSINIT
  1220.       BP = 0
  1221.       NOWARN = 0
  1222.  
  1223.       DO 200 I = 1,52
  1224.           NR(I) = 0
  1225.   200 CONTINUE
  1226. C
  1227. C  INITIALISE IN-LINE COMMAND EXPANSION
  1228. C
  1229.       EMBEDU = .FALSE.
  1230.       CHUBED(1) = 60
  1231.       CHUBED(2) = 95
  1232.       CHUBED(3) = 95
  1233.       CHUBED(4) = 62
  1234.       EMBEDB = .FALSE.
  1235.       CHBBED(1) = 60
  1236.       CHBBED(2) = 45
  1237.       CHBBED(3) = 45
  1238.       CHBBED(4) = 62
  1239.  
  1240.       END
  1241. C------------------------------------------------
  1242.       SUBROUTINE GETTL(BUF,TTL,LIM)
  1243.  
  1244.       INTEGER BUF(*),TTL(*)
  1245.       INTEGER I,LIM(2)
  1246.  
  1247. C---------------------------------------------------------
  1248. C    TOOLPACK/1    Release: 2.5
  1249. C---------------------------------------------------------
  1250.       INTEGER FILL,  LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL, BOVAL,
  1251.      +        CCHAR, BSVAL, RJUST, CUVAL
  1252.       INTEGER TABS(400), TJUST(3), CHUBED(4), CHBBED(4)
  1253.       LOGICAL EMBEDU, EMBEDB
  1254.       COMMON /CPARAM/ FILL, LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL,
  1255.      +                BOVAL, BSVAL, RJUST, CUVAL, TABS, TJUST, CCHAR,
  1256.      +                EMBEDU,CHUBED,EMBEDB,CHBBED
  1257.  
  1258.       SAVE
  1259.  
  1260.       I = 1
  1261.   100 CONTINUE
  1262.       IF (BUF(I).NE.32 .AND. BUF(I).NE.9 .AND.
  1263.      +    BUF(I).NE.10) THEN
  1264.           I = I + 1
  1265.           GO TO 100
  1266.       END IF
  1267.  
  1268.       CALL SKIPBL(BUF,I)
  1269.       CALL SCOPY(BUF,I,TTL,1)
  1270.       LIM(1) = INVAL
  1271.       LIM(2) = RMVAL
  1272.  
  1273.       END
  1274. C------------------------------------------------
  1275.       INTEGER FUNCTION GETVAL(BUF,I,ARGTYP)
  1276.  
  1277.       INTEGER BUF(*)
  1278.       INTEGER I,ARGTYP
  1279.       INTEGER CTOI
  1280.  
  1281.       CALL SKIPBL(BUF,I)
  1282.       ARGTYP = BUF(I)
  1283.       IF (ARGTYP.EQ.43 .OR. ARGTYP.EQ.45) I = I + 1
  1284.       IF (BUF(I).EQ.34) THEN
  1285.           GETVAL = -1
  1286.   100     CONTINUE
  1287.           I = I + 1
  1288.           GETVAL = GETVAL + 1
  1289.           IF (BUF(I).NE.34 .AND. BUF(I).NE.129 .AND.
  1290.      +        BUF(I).NE.10) GO TO 100
  1291.       ELSE
  1292.           GETVAL = CTOI(BUF,I)
  1293.       END IF
  1294.  
  1295.       END
  1296. C------------------------------------------------
  1297.       INTEGER FUNCTION GETWRB(IN,I,OUT)
  1298.  
  1299.       INTEGER IN(*),OUT(*)
  1300.       INTEGER I,J
  1301.  
  1302.       J = 1
  1303.   100 CONTINUE
  1304.       IF (IN(I).NE.129 .AND. IN(I).NE.32 .AND. IN(I).NE.9 .AND.
  1305.      +    IN(I).NE.10) THEN
  1306.           OUT(J) = IN(I)
  1307.           I = I + 1
  1308.           J = J + 1
  1309.           GO TO 100
  1310.       END IF
  1311.   200 CONTINUE
  1312.  
  1313.       IF (IN(I).EQ.32) THEN
  1314.           OUT(J) = 32
  1315.           I = I + 1
  1316.           J = J + 1
  1317.           GO TO 200
  1318.       END IF
  1319.       OUT(J) = 129
  1320.       GETWRB = J - 1
  1321.  
  1322.       END
  1323. C------------------------------------------------
  1324. C
  1325. C  COPY A SUB-FIELD OF AT MOST N CHARACTERS FROM BUF
  1326. C  TO TEMP. START AT BUF(I).
  1327. C
  1328.       INTEGER FUNCTION GFIELD(BUF,I,N,TEMP,DELIM)
  1329.  
  1330.       INTEGER BUF(*),TEMP(*),DELIM
  1331.       INTEGER I,J,N
  1332.  
  1333.       J = 1
  1334.       IF (N.GT.0) THEN
  1335.           IF (BUF(I).EQ.DELIM) I = I + 1
  1336.   100     CONTINUE
  1337.           IF (BUF(I).NE.DELIM .AND. BUF(I).NE.129 .AND.
  1338.      +        BUF(I).NE.10 .AND. J.LE.N) THEN
  1339.               TEMP(J) = BUF(I)
  1340.               J = J + 1
  1341.               I = I + 1
  1342.               GO TO 100
  1343.           END IF
  1344.       END IF
  1345.  
  1346.       TEMP(J) = 129
  1347.       GFIELD = J - 1
  1348.   200 CONTINUE
  1349.       IF (BUF(I).NE.DELIM .AND. BUF(I).NE.129 .AND.
  1350.      +    BUF(I).NE.10) THEN
  1351.           I = I + 1
  1352.           GO TO 200
  1353.       END IF
  1354.  
  1355.       END
  1356. C------------------------------------------------
  1357.       SUBROUTINE JCOPY(FROM,I,TO,J)
  1358.  
  1359.       INTEGER FROM(*),TO(*)
  1360.       INTEGER I,J,K1,K2
  1361.  
  1362.       K1 = I
  1363.       K2 = J
  1364.   100 CONTINUE
  1365.       IF (FROM(K1).NE.129) THEN
  1366.           TO(K2) = FROM(K1)
  1367.           K1 = K1 + 1
  1368.           K2 = K2 + 1
  1369.           GO TO 100
  1370.       END IF
  1371.  
  1372.       END
  1373. C------------------------------------------------
  1374.       SUBROUTINE JUSTFY(IN,LEFT,RIGHT,TYPE,OUT)
  1375.  
  1376.       INTEGER IN(*),OUT(*)
  1377.       INTEGER LEFT,RIGHT,TYPE,J,N,WIDTH
  1378.       INTRINSIC MAX
  1379.  
  1380.       N = WIDTH(IN)
  1381.       IF (TYPE.EQ.3) THEN
  1382.           CALL JCOPY(IN,1,OUT,RIGHT-N)
  1383.       ELSE IF (TYPE.EQ.2) THEN
  1384.           J = MAX((RIGHT+LEFT-N)/2,LEFT)
  1385.           CALL JCOPY(IN,1,OUT,J)
  1386.       ELSE
  1387.           CALL JCOPY(IN,1,OUT,LEFT)
  1388.       END IF
  1389.  
  1390.       END
  1391. C------------------------------------------------
  1392.       SUBROUTINE LEADBL(BUF)
  1393.  
  1394.       INTEGER BUF(*)
  1395.       INTEGER I,J
  1396.  
  1397. C---------------------------------------------------------
  1398. C    TOOLPACK/1    Release: 2.5
  1399. C---------------------------------------------------------
  1400.       INTEGER FILL,  LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL, BOVAL,
  1401.      +        CCHAR, BSVAL, RJUST, CUVAL
  1402.       INTEGER TABS(400), TJUST(3), CHUBED(4), CHBBED(4)
  1403.       LOGICAL EMBEDU, EMBEDB
  1404.       COMMON /CPARAM/ FILL, LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL,
  1405.      +                BOVAL, BSVAL, RJUST, CUVAL, TABS, TJUST, CCHAR,
  1406.      +                EMBEDU,CHUBED,EMBEDB,CHBBED
  1407.  
  1408.       SAVE
  1409.  
  1410.       CALL BRK
  1411.       I = 1
  1412.   100 CONTINUE
  1413.       IF (BUF(I).EQ.32) THEN
  1414.           I = I + 1
  1415.           GO TO 100
  1416.       END IF
  1417.       IF (BUF(I).NE.10) TIVAL = TIVAL + I - 1
  1418.  
  1419.       J = 1
  1420.       IF (J.NE.I) THEN
  1421.   200     CONTINUE
  1422.           BUF(J) = BUF(I)
  1423.           I = I + 1
  1424.           J = J + 1
  1425.           IF (BUF(J-1).NE.129) GO TO 200
  1426.       END IF
  1427.  
  1428.       END
  1429. C------------------------------------------------
  1430.       INTEGER FUNCTION NGETCH(C,FD)
  1431.  
  1432.       INTEGER C,FD
  1433.       INTEGER GETCH
  1434. C---------------------------------------------------------
  1435. C    TOOLPACK/1    Release: 2.5
  1436. C---------------------------------------------------------
  1437.       INTEGER BP
  1438.       INTEGER BUF(400)
  1439.       COMMON /CDEFIO/ BP, BUF
  1440.  
  1441. C---------------------------------------------------------
  1442. C    TOOLPACK/1    Release: 2.5
  1443. C---------------------------------------------------------
  1444.       INTEGER INFILE(8)
  1445.       INTEGER LEVEL
  1446.       COMMON /RFIO/ INFILE, LEVEL
  1447. C---------------------------------------------------------
  1448. C    TOOLPACK/1    Release: 2.5
  1449. C---------------------------------------------------------
  1450.       INTEGER OUTP, OUTW, OUTWDS
  1451.       INTEGER OUTBUF(400)
  1452.       LOGICAL ATEND, LEGEN
  1453.       COMMON /COUT/ OUTP, OUTW, OUTWDS, OUTBUF, ATEND, LEGEN
  1454.  
  1455.       SAVE
  1456.  
  1457.       IF (BP.GT.0) THEN
  1458.           C = BUF(BP)
  1459.           BP = BP - 1
  1460.       ELSE
  1461.           C = GETCH(C,FD)
  1462.       END IF
  1463.  
  1464.       IF (LEVEL.EQ.1 .AND. C.EQ.-100 .AND. LEGEN) ATEND = .TRUE.
  1465.       NGETCH = C
  1466.  
  1467.       END
  1468. C------------------------------------------------
  1469.       INTEGER FUNCTION NGETLN(LINE,F)
  1470.  
  1471.       INTEGER LINE(*),C,NGETCH
  1472.       INTEGER F
  1473.  
  1474.       NGETLN = 0
  1475.   100 CONTINUE
  1476.       IF (NGETCH(C,F).NE.-100) THEN
  1477.           IF (NGETLN.LT.132-1) THEN
  1478.               NGETLN = NGETLN + 1
  1479.               LINE(NGETLN) = C
  1480.           END IF
  1481.           IF (C.NE.10) GO TO 100
  1482.       END IF
  1483.  
  1484.       LINE(NGETLN+1) = 129
  1485.       IF (NGETLN.EQ.0 .AND. C.EQ.-100) NGETLN = -100
  1486.  
  1487.       END
  1488. C------------------------------------------------
  1489.       SUBROUTINE PBSTR(IN)
  1490.  
  1491.       INTEGER IN(*)
  1492.       INTEGER LENGTH
  1493.       INTEGER I
  1494.  
  1495.       DO 100 I = LENGTH(IN),1,-1
  1496.           CALL PUTBAK(IN(I))
  1497.   100 CONTINUE
  1498.  
  1499.       END
  1500. C------------------------------------------------
  1501.       SUBROUTINE PFOOT
  1502.  
  1503.       INTRINSIC MOD
  1504. C---------------------------------------------------------
  1505. C    TOOLPACK/1    Release: 2.5
  1506. C---------------------------------------------------------
  1507.       INTEGER CURPAG, NEWPAG, LINENO, PLVAL,  M1VAL, M2VAL,  M3VAL,
  1508.      +        M4VAL,  BOTTOM, FRSTPG, LASTPG, PRINT, OFFSET, FDOUT,
  1509.      +        NOWARN, FDSAVE
  1510.       LOGICAL STOPH, STOPF, STOPP, NORMFD
  1511.       INTEGER EHEAD(134), OHEAD(134), EHLIM(2), OHLIM(2),
  1512.      +        EFOOT(134), OFOOT(134), EFLIM(2), OFLIM(2),
  1513.      +        LINEXX(134), LINLIM(2)
  1514.       COMMON /CPAGE/ CURPAG,NEWPAG,LINENO,PLVAL,M1VAL,M2VAL,M3VAL,M4VAL,
  1515.      +               BOTTOM,STOPH,STOPF,STOPP,
  1516.      +               FRSTPG,LASTPG,PRINT,OFFSET,FDOUT,FDSAVE,NORMFD,
  1517.      +               EHEAD,OHEAD,EHLIM,OHLIM,
  1518.      +               EFOOT,OFOOT,EFLIM,OFLIM,
  1519.      +               LINEXX, LINLIM, NOWARN
  1520.       SAVE
  1521.  
  1522.       CALL SKIPF(M3VAL)
  1523.       IF (M4VAL.GT.0) THEN
  1524.           IF (MOD(CURPAG,2).EQ.0) THEN
  1525.               CALL PUTTL(EFOOT,EFLIM,CURPAG)
  1526.           ELSE
  1527.               CALL PUTTL(OFOOT,OFLIM,CURPAG)
  1528.           END IF
  1529.           CALL SKIPF(M4VAL-1)
  1530.       END IF
  1531.       IF (STOPF .AND. PRINT.EQ.-2) CALL PRMPT
  1532.  
  1533.       END
  1534. C------------------------------------------------
  1535.       SUBROUTINE PHEAD
  1536.  
  1537. C---------------------------------------------------------
  1538. C    TOOLPACK/1    Release: 2.5
  1539. C---------------------------------------------------------
  1540.       INTEGER CURPAG, NEWPAG, LINENO, PLVAL,  M1VAL, M2VAL,  M3VAL,
  1541.      +        M4VAL,  BOTTOM, FRSTPG, LASTPG, PRINT, OFFSET, FDOUT,
  1542.      +        NOWARN, FDSAVE
  1543.       LOGICAL STOPH, STOPF, STOPP, NORMFD
  1544.       INTEGER EHEAD(134), OHEAD(134), EHLIM(2), OHLIM(2),
  1545.      +        EFOOT(134), OFOOT(134), EFLIM(2), OFLIM(2),
  1546.      +        LINEXX(134), LINLIM(2)
  1547.       COMMON /CPAGE/ CURPAG,NEWPAG,LINENO,PLVAL,M1VAL,M2VAL,M3VAL,M4VAL,
  1548.      +               BOTTOM,STOPH,STOPF,STOPP,
  1549.      +               FRSTPG,LASTPG,PRINT,OFFSET,FDOUT,FDSAVE,NORMFD,
  1550.      +               EHEAD,OHEAD,EHLIM,OHLIM,
  1551.      +               EFOOT,OFOOT,EFLIM,OFLIM,
  1552.      +               LINEXX, LINLIM, NOWARN
  1553.       SAVE
  1554.       INTRINSIC MOD
  1555.  
  1556.       CURPAG = NEWPAG
  1557.       IF (CURPAG.GE.FRSTPG .AND. CURPAG.LE.LASTPG) THEN
  1558.           PRINT = -2
  1559.       ELSE
  1560.           PRINT = -3
  1561.       END IF
  1562.  
  1563.       IF (STOPH .AND. PRINT.EQ.-2) CALL PRMPT
  1564.       NEWPAG = NEWPAG + 1
  1565.       IF (M1VAL.GT.0) THEN
  1566.           CALL SKIPF(M1VAL-1)
  1567.           IF (MOD(CURPAG,2).EQ.0) THEN
  1568.               CALL PUTTL(EHEAD,EHLIM,CURPAG)
  1569.           ELSE
  1570.               CALL PUTTL(OHEAD,OHLIM,CURPAG)
  1571.           END IF
  1572.       END IF
  1573.       CALL SKIPF(M2VAL)
  1574.       LINENO = M1VAL + M2VAL + 1
  1575.  
  1576.       END
  1577. C------------------------------------------
  1578.       SUBROUTINE PRMPT
  1579.  
  1580.       INTEGER JUNK
  1581.       INTEGER GETLIN
  1582.       INTEGER LINE(134)
  1583.       INTEGER TELL(32)
  1584. C---------------------------------------------------------
  1585. C    TOOLPACK/1    Release: 2.5
  1586. C---------------------------------------------------------
  1587.       INTEGER CURPAG, NEWPAG, LINENO, PLVAL,  M1VAL, M2VAL,  M3VAL,
  1588.      +        M4VAL,  BOTTOM, FRSTPG, LASTPG, PRINT, OFFSET, FDOUT,
  1589.      +        NOWARN, FDSAVE
  1590.       LOGICAL STOPH, STOPF, STOPP, NORMFD
  1591.       INTEGER EHEAD(134), OHEAD(134), EHLIM(2), OHLIM(2),
  1592.      +        EFOOT(134), OFOOT(134), EFLIM(2), OFLIM(2),
  1593.      +        LINEXX(134), LINLIM(2)
  1594.       COMMON /CPAGE/ CURPAG,NEWPAG,LINENO,PLVAL,M1VAL,M2VAL,M3VAL,M4VAL,
  1595.      +               BOTTOM,STOPH,STOPF,STOPP,
  1596.      +               FRSTPG,LASTPG,PRINT,OFFSET,FDOUT,FDSAVE,NORMFD,
  1597.      +               EHEAD,OHEAD,EHLIM,OHLIM,
  1598.      +               EFOOT,OFOOT,EFLIM,OFLIM,
  1599.      +               LINEXX, LINLIM, NOWARN
  1600.       SAVE
  1601.  
  1602.       DATA TELL/84,121,112,101,32,82,69,84,85,82,78,
  1603.      +     32,116,111,32,98,101,103,105,110,32,110,
  1604.      +     101,119,32,112,97,103,101,58,32,129/
  1605.  
  1606.       IF (STOPP) CALL ZPRMPT(TELL)
  1607.       JUNK = GETLIN(LINE,0)
  1608.  
  1609.       END
  1610. C------------------------------------------------
  1611.       SUBROUTINE PUT(BUF)
  1612.  
  1613.       INTEGER BUF(*)
  1614.       INTEGER I,COUNT,NOCHAR,CBFLAG,CUFLAG
  1615.       INTRINSIC MIN
  1616.  
  1617. C---------------------------------------------------------
  1618. C    TOOLPACK/1    Release: 2.5
  1619. C---------------------------------------------------------
  1620.       INTEGER CURPAG, NEWPAG, LINENO, PLVAL,  M1VAL, M2VAL,  M3VAL,
  1621.      +        M4VAL,  BOTTOM, FRSTPG, LASTPG, PRINT, OFFSET, FDOUT,
  1622.      +        NOWARN, FDSAVE
  1623.       LOGICAL STOPH, STOPF, STOPP, NORMFD
  1624.       INTEGER EHEAD(134), OHEAD(134), EHLIM(2), OHLIM(2),
  1625.      +        EFOOT(134), OFOOT(134), EFLIM(2), OFLIM(2),
  1626.      +        LINEXX(134), LINLIM(2)
  1627.       COMMON /CPAGE/ CURPAG,NEWPAG,LINENO,PLVAL,M1VAL,M2VAL,M3VAL,M4VAL,
  1628.      +               BOTTOM,STOPH,STOPF,STOPP,
  1629.      +               FRSTPG,LASTPG,PRINT,OFFSET,FDOUT,FDSAVE,NORMFD,
  1630.      +               EHEAD,OHEAD,EHLIM,OHLIM,
  1631.      +               EFOOT,OFOOT,EFLIM,OFLIM,
  1632.      +               LINEXX, LINLIM, NOWARN
  1633. C---------------------------------------------------------
  1634. C    TOOLPACK/1    Release: 2.5
  1635. C---------------------------------------------------------
  1636.       INTEGER FILL,  LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL, BOVAL,
  1637.      +        CCHAR, BSVAL, RJUST, CUVAL
  1638.       INTEGER TABS(400), TJUST(3), CHUBED(4), CHBBED(4)
  1639.       LOGICAL EMBEDU, EMBEDB
  1640.       COMMON /CPARAM/ FILL, LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL,
  1641.      +                BOVAL, BSVAL, RJUST, CUVAL, TABS, TJUST, CCHAR,
  1642.      +                EMBEDU,CHUBED,EMBEDB,CHBBED
  1643.  
  1644. C---------------------------------------------------------
  1645. C    TOOLPACK/1    Release: 2.5
  1646. C---------------------------------------------------------
  1647.       LOGICAL BARFLG, ENDBAR, DELFLG
  1648.       INTEGER BARCHR, DELCHR, FSCHAR
  1649.       COMMON /CBAR/ BARFLG, BARCHR, DELFLG, ENDBAR, DELCHR, FSCHAR
  1650.       SAVE
  1651.  
  1652.       DATA CUFLAG/-3/,CBFLAG/-3/
  1653.  
  1654.       IF (LINENO.EQ.0 .OR. LINENO.GT.BOTTOM) CALL PHEAD
  1655.       IF (PRINT.EQ.-2) THEN
  1656.  
  1657.           DO 100 I = 1,TIVAL + OFFSET
  1658.               CALL PUTCH(32,FDOUT)
  1659.   100     CONTINUE
  1660.           COUNT = TIVAL
  1661.           NOCHAR = TIVAL
  1662.  
  1663.           I = 1
  1664.   200     CONTINUE
  1665.           IF (BUF(I).NE.129 .AND. BUF(I).NE.10) THEN
  1666.               IF (BUF(I).EQ.-10) THEN
  1667.                   IF (EMBEDU) THEN
  1668.                       CALL PUTCH(CHUBED(1),FDOUT)
  1669.                       CALL PUTCH(CHUBED(2),FDOUT)
  1670.                       NOCHAR = NOCHAR + 2
  1671.                   ELSE
  1672.                       CUFLAG = -2
  1673.                   END IF
  1674.               ELSE IF (BUF(I).EQ.-11) THEN
  1675.                   IF (EMBEDU) THEN
  1676.                       CALL PUTCH(CHUBED(3),FDOUT)
  1677.                       CALL PUTCH(CHUBED(4),FDOUT)
  1678.                       NOCHAR = NOCHAR + 2
  1679.                   ELSE
  1680.                       CUFLAG = -3
  1681.                   END IF
  1682.  
  1683.               ELSE IF (BUF(I).EQ.-50) THEN
  1684.                   IF (EMBEDB) THEN
  1685.                       CALL PUTCH(CHBBED(1),FDOUT)
  1686.                       CALL PUTCH(CHBBED(2),FDOUT)
  1687.                       NOCHAR = NOCHAR + 2
  1688.                   ELSE
  1689.                       CBFLAG = -2
  1690.                   END IF
  1691.               ELSE IF (BUF(I).EQ.-51) THEN
  1692.                   IF (EMBEDB) THEN
  1693.                       CALL PUTCH(CHBBED(3),FDOUT)
  1694.                       CALL PUTCH(CHBBED(4),FDOUT)
  1695.                       NOCHAR = NOCHAR + 2
  1696.                   ELSE
  1697.                       CBFLAG = -3
  1698.                   END IF
  1699.               ELSE
  1700.  
  1701.                   IF (CUFLAG.EQ.-2) THEN
  1702.                       CALL PUTCH(95,FDOUT)
  1703.                       CALL PUTCH(8,FDOUT)
  1704.                       NOCHAR = NOCHAR + 2
  1705.                   END IF
  1706.                   IF (CBFLAG.EQ.-2) THEN
  1707.                       IF (BUF(I).EQ.-20) THEN
  1708.                           CALL PUTCH(32,FDOUT)
  1709.                       ELSE
  1710.                           CALL PUTCH(BUF(I),FDOUT)
  1711.                       END IF
  1712.                       CALL PUTCH(8,FDOUT)
  1713.                       NOCHAR = NOCHAR + 2
  1714.                   END IF
  1715.                   IF (BUF(I).EQ.-20) THEN
  1716.                       CALL PUTCH(32,FDOUT)
  1717.                   ELSE
  1718.                       CALL PUTCH(BUF(I),FDOUT)
  1719.                   END IF
  1720.                   COUNT = COUNT + 1
  1721.                   NOCHAR = NOCHAR + 1
  1722.               END IF
  1723.  
  1724.               I = I + 1
  1725.               GO TO 200
  1726.           END IF
  1727. C
  1728. C  OBEY THE CHANGE BAR REQUESTS....
  1729. C
  1730.           IF (DELFLG) THEN
  1731.               DO 300 I = COUNT,RMVAL + 3
  1732.                   CALL PUTCH(32,FDOUT)
  1733.   300         CONTINUE
  1734.               CALL PUTCH(DELCHR,FDOUT)
  1735.               NOCHAR = NOCHAR + 3 + MAX(0,RMVAL+3-COUNT)
  1736.               DELFLG = .FALSE.
  1737.           ELSE IF (BARFLG) THEN
  1738.               DO 400 I = COUNT,RMVAL + 3
  1739.                   CALL PUTCH(32,FDOUT)
  1740.   400         CONTINUE
  1741.               NOCHAR = NOCHAR + 3 + MAX(0,RMVAL+3-COUNT)
  1742.               CALL PUTCH(BARCHR,FDOUT)
  1743.           END IF
  1744.           IF (ENDBAR) THEN
  1745.               ENDBAR = .FALSE.
  1746.               BARFLG = .FALSE.
  1747.           END IF
  1748.           CALL PUTCH(10,FDOUT)
  1749. C
  1750. C  CHECK THE NUMBER OF CHARACTERS ACTUALLY OUTPUT....
  1751. C
  1752.           IF (NOCHAR.GT.132) THEN
  1753.               NOWARN = NOWARN + 1
  1754.               CALL ZCHOUT('[ISTRF - WARNING: Line .',2)
  1755.               CALL ZPTINT(LINENO,1,2)
  1756.               CALL ZCHOUT(' on page .',2)
  1757.               CALL ZPTINT(CURPAG,1,2)
  1758.               CALL ZMESS(' too long].',2)
  1759.           END IF
  1760.       END IF
  1761. C
  1762. C  RESET THE LINE-AT-A-TIME VALUES AND CHECK FOR BOTTOM
  1763. C  OF PAGE.
  1764. C
  1765.       TIVAL = INVAL
  1766.       CALL SKIPF(MIN(LSVAL-1,BOTTOM-LINENO))
  1767.       LINENO = LINENO + LSVAL
  1768.       IF (LINENO.GT.BOTTOM) CALL PFOOT
  1769.  
  1770.       END
  1771. C------------------------------------------------
  1772.       SUBROUTINE PUTBAK(C)
  1773.  
  1774.       INTEGER C
  1775. C---------------------------------------------------------
  1776. C    TOOLPACK/1    Release: 2.5
  1777. C---------------------------------------------------------
  1778.       INTEGER BP
  1779.       INTEGER BUF(400)
  1780.       COMMON /CDEFIO/ BP, BUF
  1781.  
  1782.       SAVE
  1783.  
  1784.       BP = BP + 1
  1785.       IF (BP.GT.400) CALL ERROR(
  1786.      +                   'RF: TOO MANY CHARACTERS PUSHED BACK (PUTBAK).'
  1787.      +                              )
  1788.       BUF(BP) = C
  1789.  
  1790.       END
  1791. C------------------------------------------------
  1792.       SUBROUTINE PUTTL(BUF,LIM,PAGENO)
  1793.  
  1794.       INTEGER BUF(*),CHARS(20),DELIM,CDATE(15)
  1795.       INTEGER PAGENO,LIM(*),LAST(8)
  1796.       INTEGER NC,ITOC,I,J,N,LEFT,RIGHT,GFIELD,NCD,NOW(7)
  1797.       INTEGER LENGTH
  1798. C---------------------------------------------------------
  1799. C    TOOLPACK/1    Release: 2.5
  1800. C---------------------------------------------------------
  1801.       INTEGER CURPAG, NEWPAG, LINENO, PLVAL,  M1VAL, M2VAL,  M3VAL,
  1802.      +        M4VAL,  BOTTOM, FRSTPG, LASTPG, PRINT, OFFSET, FDOUT,
  1803.      +        NOWARN, FDSAVE
  1804.       LOGICAL STOPH, STOPF, STOPP, NORMFD
  1805.       INTEGER EHEAD(134), OHEAD(134), EHLIM(2), OHLIM(2),
  1806.      +        EFOOT(134), OFOOT(134), EFLIM(2), OFLIM(2),
  1807.      +        LINEXX(134), LINLIM(2)
  1808.       COMMON /CPAGE/ CURPAG,NEWPAG,LINENO,PLVAL,M1VAL,M2VAL,M3VAL,M4VAL,
  1809.      +               BOTTOM,STOPH,STOPF,STOPP,
  1810.      +               FRSTPG,LASTPG,PRINT,OFFSET,FDOUT,FDSAVE,NORMFD,
  1811.      +               EHEAD,OHEAD,EHLIM,OHLIM,
  1812.      +               EFOOT,OFOOT,EFLIM,OFLIM,
  1813.      +               LINEXX, LINLIM, NOWARN
  1814. C---------------------------------------------------------
  1815. C    TOOLPACK/1    Release: 2.5
  1816. C---------------------------------------------------------
  1817.       INTEGER FILL,  LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL, BOVAL,
  1818.      +        CCHAR, BSVAL, RJUST, CUVAL
  1819.       INTEGER TABS(400), TJUST(3), CHUBED(4), CHBBED(4)
  1820.       LOGICAL EMBEDU, EMBEDB
  1821.       COMMON /CPARAM/ FILL, LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL,
  1822.      +                BOVAL, BSVAL, RJUST, CUVAL, TABS, TJUST, CCHAR,
  1823.      +                EMBEDU,CHUBED,EMBEDB,CHBBED
  1824.  
  1825. C---------------------------------------------------------
  1826. C    TOOLPACK/1    Release: 2.5
  1827. C---------------------------------------------------------
  1828.       INTEGER TBUF1(134),TBUF2(134),TBUF3(134),TTL(134)
  1829.       COMMON /CTEMP/ TBUF1, TBUF2, TTL, TBUF3
  1830.  
  1831. C---------------------------------------------------------
  1832. C    TOOLPACK/1    Release: 2.5
  1833. C---------------------------------------------------------
  1834.       INTEGER OUTP, OUTW, OUTWDS
  1835.       INTEGER OUTBUF(400)
  1836.       LOGICAL ATEND, LEGEN
  1837.       COMMON /COUT/ OUTP, OUTW, OUTWDS, OUTBUF, ATEND, LEGEN
  1838.  
  1839.       SAVE
  1840.  
  1841.       DATA LAST/32,40,108,97,115,116,41,129/
  1842.  
  1843.       IF (PRINT.NE.-3) THEN
  1844.           LEFT = LIM(1) + 1
  1845.           RIGHT = LIM(2) + 1
  1846.           NC = ITOC(PAGENO,CHARS,20)
  1847.           IF (ATEND) THEN
  1848.               CALL SCOPY(LAST,1,CHARS,LENGTH(CHARS)+1)
  1849.               NC = LENGTH(CHARS)
  1850.           END IF
  1851.           CALL GETNOW(NOW)
  1852.           CALL FMTDAT(CDATE,NOW,NCD)
  1853.           I = 1
  1854.           DELIM = BUF(I)
  1855.           DO 100 J = 1,RIGHT - 1
  1856.               TTL(J) = 32
  1857.   100     CONTINUE
  1858.  
  1859.           N = 0
  1860.   200     CONTINUE
  1861.           N = N + 1
  1862.           IF (GFIELD(BUF,I,RIGHT-LEFT,TBUF1,DELIM).GT.0) THEN
  1863.               CALL SUBST(TBUF1,35,TBUF2,CHARS,NC)
  1864.               CALL SUBST(TBUF2,37,TBUF1,CDATE,NCD)
  1865.               CALL JUSTFY(TBUF1,LEFT,RIGHT,TJUST(N),TTL)
  1866.           END IF
  1867.           IF (BUF(I).NE.129 .AND. BUF(I).NE.10 .AND.
  1868.      +        N.NE.3) GO TO 200
  1869.   300     CONTINUE
  1870.  
  1871.           IF (RIGHT.GT.1 .AND. TTL(RIGHT-1).EQ.32) THEN
  1872.               RIGHT = RIGHT - 1
  1873.               GO TO 300
  1874.           END IF
  1875.           TTL(RIGHT) = 10
  1876.           TTL(RIGHT+1) = 129
  1877.           I = 1
  1878.           DO 400 I = 1,OFFSET
  1879.               CALL PUTCH(32,FDOUT)
  1880.   400     CONTINUE
  1881.           CALL PUTLIN(TTL,FDOUT)
  1882.       END IF
  1883.  
  1884.       END
  1885. C------------------------------------------------
  1886.       SUBROUTINE PUTWRD(WRDBUF)
  1887.  
  1888.       INTEGER WRDBUF(*)
  1889.       INTEGER LENGTH,WIDTH
  1890.       INTEGER LAST,LLVAL,NEXTRA,W
  1891. C---------------------------------------------------------
  1892. C    TOOLPACK/1    Release: 2.5
  1893. C---------------------------------------------------------
  1894.       INTEGER OUTP, OUTW, OUTWDS
  1895.       INTEGER OUTBUF(400)
  1896.       LOGICAL ATEND, LEGEN
  1897.       COMMON /COUT/ OUTP, OUTW, OUTWDS, OUTBUF, ATEND, LEGEN
  1898.  
  1899. C---------------------------------------------------------
  1900. C    TOOLPACK/1    Release: 2.5
  1901. C---------------------------------------------------------
  1902.       INTEGER FILL,  LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL, BOVAL,
  1903.      +        CCHAR, BSVAL, RJUST, CUVAL
  1904.       INTEGER TABS(400), TJUST(3), CHUBED(4), CHBBED(4)
  1905.       LOGICAL EMBEDU, EMBEDB
  1906.       COMMON /CPARAM/ FILL, LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL,
  1907.      +                BOVAL, BSVAL, RJUST, CUVAL, TABS, TJUST, CCHAR,
  1908.      +                EMBEDU,CHUBED,EMBEDB,CHBBED
  1909.  
  1910.       SAVE
  1911.  
  1912.       W = WIDTH(WRDBUF)
  1913.       LAST = LENGTH(WRDBUF) + OUTP
  1914.       LLVAL = RMVAL - TIVAL
  1915.       IF (OUTW+W.GT.LLVAL+1 .OR. LAST.GE.400) THEN
  1916.           LAST = LAST - OUTP
  1917.           NEXTRA = LLVAL - OUTW
  1918.           OUTP = OUTP + 1
  1919.   100     CONTINUE
  1920.           IF (OUTP.GT.1) THEN
  1921.               IF (OUTBUF(OUTP-1).EQ.32) THEN
  1922.                   NEXTRA = NEXTRA + 1
  1923.                   OUTP = OUTP - 1
  1924.                   GO TO 100
  1925.               END IF
  1926.           END IF
  1927.           IF (RJUST.EQ.-2) THEN
  1928.               CALL SPREAD(OUTBUF,OUTP,NEXTRA,OUTWDS)
  1929.               IF (NEXTRA.GT.0 .AND. OUTWDS.GT.1) OUTP = OUTP + NEXTRA
  1930.           END IF
  1931.           CALL BRK
  1932.       END IF
  1933.  
  1934.       CALL SCOPY(WRDBUF,1,OUTBUF,OUTP+1)
  1935.       OUTP = LAST
  1936.       OUTW = OUTW + W
  1937.       OUTWDS = OUTWDS + 1
  1938.  
  1939.       END
  1940. C------------------------------------------------
  1941.       SUBROUTINE SPACE(N)
  1942.  
  1943.       INTRINSIC MIN
  1944.       INTEGER N
  1945. C---------------------------------------------------------
  1946. C    TOOLPACK/1    Release: 2.5
  1947. C---------------------------------------------------------
  1948.       INTEGER CURPAG, NEWPAG, LINENO, PLVAL,  M1VAL, M2VAL,  M3VAL,
  1949.      +        M4VAL,  BOTTOM, FRSTPG, LASTPG, PRINT, OFFSET, FDOUT,
  1950.      +        NOWARN, FDSAVE
  1951.       LOGICAL STOPH, STOPF, STOPP, NORMFD
  1952.       INTEGER EHEAD(134), OHEAD(134), EHLIM(2), OHLIM(2),
  1953.      +        EFOOT(134), OFOOT(134), EFLIM(2), OFLIM(2),
  1954.      +        LINEXX(134), LINLIM(2)
  1955.       COMMON /CPAGE/ CURPAG,NEWPAG,LINENO,PLVAL,M1VAL,M2VAL,M3VAL,M4VAL,
  1956.      +               BOTTOM,STOPH,STOPF,STOPP,
  1957.      +               FRSTPG,LASTPG,PRINT,OFFSET,FDOUT,FDSAVE,NORMFD,
  1958.      +               EHEAD,OHEAD,EHLIM,OHLIM,
  1959.      +               EFOOT,OFOOT,EFLIM,OFLIM,
  1960.      +               LINEXX, LINLIM, NOWARN
  1961.       SAVE
  1962.  
  1963.       CALL BRK
  1964.       IF (LINENO.LE.BOTTOM) THEN
  1965.           IF (LINENO.EQ.0) CALL PHEAD
  1966.           CALL SKIPF(MIN(N,BOTTOM+1-LINENO))
  1967.           LINENO = LINENO + N
  1968.           IF (LINENO.GT.BOTTOM) CALL PFOOT
  1969.       END IF
  1970.  
  1971.       END
  1972. C------------------------------------------------
  1973.       SUBROUTINE SPREAD(BUF,OUTP,NEXTRA,OUTWDS)
  1974.  
  1975.       INTEGER BUF(*)
  1976. C---------------------------------------------------------
  1977. C    TOOLPACK/1    Release: 2.5
  1978. C---------------------------------------------------------
  1979.       INTEGER FILL,  LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL, BOVAL,
  1980.      +        CCHAR, BSVAL, RJUST, CUVAL
  1981.       INTEGER TABS(400), TJUST(3), CHUBED(4), CHBBED(4)
  1982.       LOGICAL EMBEDU, EMBEDB
  1983.       COMMON /CPARAM/ FILL, LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL,
  1984.      +                BOVAL, BSVAL, RJUST, CUVAL, TABS, TJUST, CCHAR,
  1985.      +                EMBEDU,CHUBED,EMBEDB,CHBBED
  1986.  
  1987.       SAVE
  1988.       INTEGER DIR,I,J,NB,NE,NEXTRA,NHOLES,OUTP,OUTWDS
  1989.       INTRINSIC MIN
  1990.       DATA DIR/0/
  1991.  
  1992.       IF (NEXTRA.GT.0 .AND. OUTWDS.GT.1) THEN
  1993.           DIR = 1 - DIR
  1994.           NE = NEXTRA
  1995.           NHOLES = OUTWDS - 1
  1996.           IF (TIVAL.NE.INVAL .AND. NHOLES.GT.1) NHOLES = NHOLES - 1
  1997.           I = OUTP - 1
  1998.           J = MIN(400-2,I+NE)
  1999.   100     CONTINUE
  2000.           IF (I.LT.J) THEN
  2001.               BUF(J) = BUF(I)
  2002.               IF (BUF(I).EQ.32 .AND. BUF(I-1).NE.32) THEN
  2003.                   IF (DIR.EQ.0) THEN
  2004.                       NB = (NE-1)/NHOLES + 1
  2005.                   ELSE
  2006.                       NB = NE/NHOLES
  2007.                   END IF
  2008.                   NE = NE - NB
  2009.                   NHOLES = NHOLES - 1
  2010.   200             CONTINUE
  2011.                   IF (NB.GT.0) THEN
  2012.                       J = J - 1
  2013.                       BUF(J) = 32
  2014.                       NB = NB - 1
  2015.                       GO TO 200
  2016.                   END IF
  2017.               END IF
  2018.               I = I - 1
  2019.               J = J - 1
  2020.               GO TO 100
  2021.           END IF
  2022.       END IF
  2023.  
  2024.       END
  2025. C------------------------------------------------
  2026.       SUBROUTINE SUBST(IN,CHAR,OUT,SUBARA,N)
  2027.  
  2028.       INTEGER IN(*),CHAR,OUT(*),SUBARA(*)
  2029.       INTEGER I,J,K,N
  2030.  
  2031.       J = 1
  2032.       I = 1
  2033.   100 CONTINUE
  2034.       IF (IN(I).NE.129) THEN
  2035.           IF (IN(I).NE.CHAR) THEN
  2036.               OUT(J) = IN(I)
  2037.               J = J + 1
  2038.               I = I + 1
  2039.           ELSE
  2040.               K = 1
  2041.   200         CONTINUE
  2042.               IF (K.LE.N) THEN
  2043.                   OUT(J) = SUBARA(K)
  2044.                   J = J + 1
  2045.                   K = K + 1
  2046.                   GO TO 200
  2047.               END IF
  2048.               I = I + 1
  2049.           END IF
  2050.           GO TO 100
  2051.       END IF
  2052.       OUT(J) = 129
  2053.  
  2054.       END
  2055. C------------------------------------------------
  2056.       SUBROUTINE TEXT(INBUF)
  2057.  
  2058.       INTEGER INBUF(*),WRDBUF(400)
  2059.       INTEGER GETWRB,LENGTH
  2060.       INTEGER I,CUFLG
  2061.  
  2062. C---------------------------------------------------------
  2063. C    TOOLPACK/1    Release: 2.5
  2064. C---------------------------------------------------------
  2065.       INTEGER FILL,  LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL, BOVAL,
  2066.      +        CCHAR, BSVAL, RJUST, CUVAL
  2067.       INTEGER TABS(400), TJUST(3), CHUBED(4), CHBBED(4)
  2068.       LOGICAL EMBEDU, EMBEDB
  2069.       COMMON /CPARAM/ FILL, LSVAL, INVAL, RMVAL, TIVAL, CEVAL, ULVAL,
  2070.      +                BOVAL, BSVAL, RJUST, CUVAL, TABS, TJUST, CCHAR,
  2071.      +                EMBEDU,CHUBED,EMBEDB,CHBBED
  2072.  
  2073.       SAVE
  2074.  
  2075.       DATA CUFLG/-3/
  2076.  
  2077.       CALL DOESC(INBUF,WRDBUF,400)
  2078.       CALL DOTABS(INBUF,WRDBUF,400)
  2079.       IF (INBUF(1).EQ.32 .OR. INBUF(1).EQ.10) CALL LEADBL(INBUF)
  2080.       IF (ULVAL.GT.0) THEN
  2081.           CALL UNDERL(INBUF,WRDBUF,400)
  2082.           ULVAL = ULVAL - 1
  2083.       END IF
  2084.       IF (CUVAL.GT.0) THEN
  2085.           IF (CUFLG.EQ.-3) THEN
  2086.               CALL SCOPY(INBUF,1,WRDBUF,1)
  2087.               INBUF(1) = -10
  2088.               CALL SCOPY(WRDBUF,1,INBUF,2)
  2089.               CUFLG = -2
  2090.           END IF
  2091.           CUVAL = CUVAL - 1
  2092.           IF (CUFLG.EQ.-2 .AND. CUVAL.EQ.0) THEN
  2093.               I = LENGTH(INBUF)
  2094.               INBUF(I) = -11
  2095.               INBUF(I+1) = 10
  2096.               INBUF(I+2) = 129
  2097.               CUFLG = -3
  2098.           END IF
  2099.       END IF
  2100.       IF (BOVAL.GT.0) THEN
  2101.           CALL BOLD2(INBUF,WRDBUF)
  2102.           BOVAL = BOVAL - 1
  2103.       END IF
  2104.       IF (CEVAL.GT.0) THEN
  2105.           CALL CENTER(INBUF)
  2106.           CALL PUT(INBUF)
  2107.           CEVAL = CEVAL - 1
  2108.       ELSE IF (INBUF(1).EQ.10) THEN
  2109.           CALL PUT(INBUF)
  2110.       ELSE IF (FILL.EQ.-3) THEN
  2111.           CALL PUT(INBUF)
  2112.       ELSE
  2113.           I = LENGTH(INBUF)
  2114.           INBUF(I) = 32
  2115.           IF (INBUF(I-1).EQ.46) THEN
  2116.               I = I + 1
  2117.               INBUF(I) = 32
  2118.           END IF
  2119.           INBUF(I+1) = 129
  2120.           I = 1
  2121.   100     CONTINUE
  2122.           IF (GETWRB(INBUF,I,WRDBUF).GT.0) THEN
  2123.               CALL PUTWRD(WRDBUF)
  2124.               GO TO 100
  2125.           END IF
  2126.       END IF
  2127.  
  2128.       END
  2129. C------------------------------------------------
  2130.       SUBROUTINE UNDERL(BUF,TBUF,SIZE)
  2131.  
  2132.       INTEGER I,J,SIZE,T,TYPE
  2133.       INTEGER BUF(*),TBUF(*)
  2134.  
  2135.       J = 1
  2136.       I = 1
  2137.   100 CONTINUE
  2138.       IF (J.LT.SIZE-1) THEN
  2139.           T = TYPE(BUF(I))
  2140.   200     CONTINUE
  2141.           IF (T.NE.1 .AND. T.NE.2 .AND. T.NE.10 .AND.
  2142.      +        T.NE.129) THEN
  2143.               TBUF(J) = BUF(I)
  2144.               I = I + 1
  2145.               J = J + 1
  2146.               T = TYPE(BUF(I))
  2147.               GO TO 200
  2148.           END IF
  2149.           IF (BUF(I).NE.129 .AND. BUF(I).NE.10) THEN
  2150.               TBUF(J) = -10
  2151.               J = J + 1
  2152.               T = TYPE(BUF(I))
  2153.   300         CONTINUE
  2154.               IF (T.EQ.1 .OR. T.EQ.2 .OR. T.EQ.45) THEN
  2155.                   TBUF(J) = BUF(I)
  2156.                   I = I + 1
  2157.                   J = J + 1
  2158.                   T = TYPE(BUF(I))
  2159.                   GO TO 300
  2160.               END IF
  2161.               TBUF(J) = -11
  2162.               J = J + 1
  2163.               GO TO 100
  2164.           END IF
  2165.       END IF
  2166.  
  2167.       TBUF(J) = 10
  2168.       TBUF(J+1) = 129
  2169.       CALL SCOPY(TBUF,1,BUF,1)
  2170.  
  2171.       END
  2172. C------------------------------------------------
  2173.       INTEGER FUNCTION WIDTH(BUF)
  2174.  
  2175.       INTEGER BUF(*)
  2176.       INTEGER I
  2177.  
  2178.       WIDTH = 0
  2179.       I = 1
  2180.   100 CONTINUE
  2181.  
  2182.       IF (BUF(I).NE.129) THEN
  2183.           IF (BUF(I).EQ.8) THEN
  2184.               WIDTH = WIDTH - 1
  2185.           ELSE IF ((BUF(I).GE.32.AND.BUF(I).LE.126) .OR.
  2186.      +             (BUF(I).EQ.-20)) THEN
  2187.               WIDTH = WIDTH + 1
  2188.           END IF
  2189.           I = I + 1
  2190.           GO TO 100
  2191.       END IF
  2192.  
  2193.       END
  2194. C------------------------------------------------
  2195.       INTEGER FUNCTION ITOA(INT,CHR)
  2196.  
  2197.       INTEGER INT
  2198.       INTEGER CHR,ALPHA(26)
  2199.       INTEGER D,INTVAL
  2200.       INTRINSIC MOD
  2201.  
  2202.       DATA ALPHA/122,97,98,99,100,101,102,103,104,105,106,
  2203.      +     107,108,109,110,111,112,113,114,115,116,117,118,
  2204.      +     119,120,121/
  2205.  
  2206.       INTVAL = IABS(INT)
  2207.       D = MOD(INTVAL,26)
  2208.       CHR = ALPHA(D+1)
  2209.       ITOA = 1
  2210.  
  2211.       END
  2212. C------------------------------------------------
  2213. C
  2214.       INTEGER FUNCTION ADDSTR(S,STR,J,MAXSIZ)
  2215.  
  2216.       INTEGER J,MAXSIZ
  2217.       INTEGER S(*),STR(MAXSIZ)
  2218.       INTEGER I,ADDSET
  2219.  
  2220.       I = 1
  2221.   100 CONTINUE
  2222.       IF (S(I).NE.129) THEN
  2223.           IF (ADDSET(S(I),STR,J,MAXSIZ).EQ.-3) THEN
  2224.               GO TO 200
  2225.           ELSE
  2226.               I = I + 1
  2227.               GO TO 100
  2228.           END IF
  2229.       END IF
  2230.  
  2231.       ADDSTR = -2
  2232.       RETURN
  2233.   200 ADDSTR = -3
  2234.  
  2235.       END
  2236. C------------------------------------------------
  2237. C
  2238. C  FORMAT THE DATE FOR HEADERS AND FOOTERS, USE A
  2239. C  TEXTUAL DATE TO AVOID THE PROBLEMS OF UK/USA
  2240. C  DATE FORMATS
  2241. C
  2242.       SUBROUTINE FMTDAT(DATE,NOW,LENT)
  2243.  
  2244.       INTEGER DATE(*),NOW(*)
  2245.       INTEGER TRIP,LENT,J
  2246.       INTEGER MONS(3,12),TEMP(6)
  2247.       INTEGER ITOC
  2248.       EXTERNAL ITOC
  2249.       SAVE
  2250.  
  2251.       DATA (MONS(I,1),I=1,3)/74,97,110/
  2252.       DATA (MONS(I,2),I=1,3)/70,101,98/
  2253.       DATA (MONS(I,3),I=1,3)/77,97,114/
  2254.       DATA (MONS(I,4),I=1,3)/65,112,114/
  2255.       DATA (MONS(I,5),I=1,3)/77,97,121/
  2256.       DATA (MONS(I,6),I=1,3)/74,117,110/
  2257.       DATA (MONS(I,7),I=1,3)/74,117,108/
  2258.       DATA (MONS(I,8),I=1,3)/65,117,103/
  2259.       DATA (MONS(I,9),I=1,3)/83,101,112/
  2260.       DATA (MONS(I,10),I=1,3)/79,99,116/
  2261.       DATA (MONS(I,11),I=1,3)/78,111,118/
  2262.       DATA (MONS(I,12),I=1,3)/68,101,99/
  2263.  
  2264.       TRIP = ITOC(NOW(3),TEMP,3)
  2265.       IF (TRIP.EQ.1) THEN
  2266.           DATE(1) = 48
  2267.           DATE(2) = TEMP(1)
  2268.       ELSE
  2269.           DATE(1) = TEMP(1)
  2270.           DATE(2) = TEMP(2)
  2271.       END IF
  2272.  
  2273.       DATE(3) = 32
  2274.       DATE(7) = 32
  2275.       DATE(12) = 129
  2276.       DO 100 J = 1,3
  2277.           DATE(3+J) = MONS(J,NOW(2))
  2278.   100 CONTINUE
  2279.       TRIP = ITOC(NOW(1),TEMP,5)
  2280.       DATE(8) = TEMP(1)
  2281.       DATE(9) = TEMP(2)
  2282.       DATE(10) = TEMP(3)
  2283.       DATE(11) = TEMP(4)
  2284.  
  2285.       LENT = 11
  2286.  
  2287.       END
  2288. C------------------------------------------------
  2289.       SUBROUTINE GETNOW(NOW)
  2290.  
  2291.       INTEGER NOW(7),YEAR,MONTH,DAY,HOUR,MINUTE,SECOND,MILLI
  2292.  
  2293.       CALL ZTIME(YEAR,MONTH,DAY,HOUR,MINUTE,SECOND,MILLI)
  2294.  
  2295.       NOW(1) = YEAR
  2296.       NOW(2) = MONTH
  2297.       NOW(3) = DAY
  2298.       NOW(4) = HOUR
  2299.       NOW(5) = MINUTE
  2300.       NOW(6) = SECOND
  2301.       NOW(7) = MILLI
  2302.  
  2303.       END
  2304. C------------------------------------------------
  2305. C
  2306. C  OUTPUT THE SPECIFIED NUMBER OF BLANK LINES ON THE
  2307. C  OUTPUT UNIT SPECIFIED BY THE FILE DESCRIPTOR FDOUT.
  2308. C
  2309.       SUBROUTINE SKIPF(COUNT)
  2310.  
  2311. C---------------------------------------------------------
  2312. C    TOOLPACK/1    Release: 2.5
  2313. C---------------------------------------------------------
  2314.       INTEGER CURPAG, NEWPAG, LINENO, PLVAL,  M1VAL, M2VAL,  M3VAL,
  2315.      +        M4VAL,  BOTTOM, FRSTPG, LASTPG, PRINT, OFFSET, FDOUT,
  2316.      +        NOWARN, FDSAVE
  2317.       LOGICAL STOPH, STOPF, STOPP, NORMFD
  2318.       INTEGER EHEAD(134), OHEAD(134), EHLIM(2), OHLIM(2),
  2319.      +        EFOOT(134), OFOOT(134), EFLIM(2), OFLIM(2),
  2320.      +        LINEXX(134), LINLIM(2)
  2321.       COMMON /CPAGE/ CURPAG,NEWPAG,LINENO,PLVAL,M1VAL,M2VAL,M3VAL,M4VAL,
  2322.      +               BOTTOM,STOPH,STOPF,STOPP,
  2323.      +               FRSTPG,LASTPG,PRINT,OFFSET,FDOUT,FDSAVE,NORMFD,
  2324.      +               EHEAD,OHEAD,EHLIM,OHLIM,
  2325.      +               EFOOT,OFOOT,EFLIM,OFLIM,
  2326.      +               LINEXX, LINLIM, NOWARN
  2327.       INTEGER COUNT,I
  2328.       SAVE
  2329.  
  2330.       DO 100 I = 1,COUNT
  2331.           CALL PUTCH(10,FDOUT)
  2332.   100 CONTINUE
  2333.  
  2334.       END
  2335. C=============================================================
  2336. C
  2337. C  INTERNAL DEFINITION TABLE HANDLING ROUTINES
  2338. C  (* - USED BY MAIN PROGRAM)
  2339. C
  2340. C * DSINIT    INITIALISE THE STORAGE TABLE
  2341. C   DSFREE    FREE SPACE IN THE STORAGE TABLE
  2342. C   DSGET     ALLOCATE SPACE IN THE STORAGE TABLE
  2343. C * ENTDEF    ENTER A DEFINITION INTO THE TABLE
  2344. C   ENTER
  2345. C   LOOKUP    SEE IF A SYMBOL ALREADY HAS A DEFINITION
  2346. C * LUDEF     LOOK FOR, AND RETURN, A DEFINITION
  2347. C   MKTABL    INITIALISE THE HASH TABLE
  2348. C   STLU
  2349. C
  2350. C------------------------------------------------
  2351. C
  2352. C  INITIALISE THE INTERNAL DEFINITIONS TABLE. THIS TABLE
  2353. C  CONTAINS A LINKED LIST OF FREE SPACE THAT CAN BE ALLOCATED
  2354. C  USING DSGET AND RELEASED USING DSFREE.
  2355. C
  2356. C  MEM(1) = THE SIZE OF THE MEMORY BUFFER
  2357. C  MEM(2) = THE SIZE OF THE FIRST BLOCK OF FREE SPACE(ALWAYS
  2358. C           SET TO 0, THIS IS A DUMMY ENTRY IN THE LINKED LIST)
  2359. C  MEM(3) = POINTER TO THE NEXT ELEMENT OF THE LINKED LIST
  2360. C  MEM(4) = THE AMOUNT OF FREE SPACE IN THE(USUALLY LAST)
  2361. C           ELEMENT OF THE LINKED LIST.
  2362. C
  2363. C  THE LINKED LIST CONTAINS A NUMBER OF ELEMENTS EACH CONSISTING
  2364. C  OF THREE PARTS:
  2365. C
  2366. C     A) THE SIZE OF THE FREE SPACE IN THIS ELEMENT
  2367. C     B) A POINTER TO THE NEXT ELEMENT
  2368. C     C) THE FREE SPACE
  2369. C
  2370.       SUBROUTINE DSINIT
  2371.  
  2372.       INTEGER MKTABL
  2373. C---------------------------------------------------------
  2374. C    TOOLPACK/1    Release: 2.5
  2375. C---------------------------------------------------------
  2376.       INTEGER MACTBL, MEMSIZ
  2377.       PARAMETER (MEMSIZ = 2500)
  2378.       INTEGER MEM(MEMSIZ)
  2379.       COMMON/CDSMEM/MEM, MACTBL
  2380.  
  2381.       SAVE
  2382.  
  2383.       MEM(1) = MEMSIZ
  2384.       MEM(2) = 0
  2385.       MEM(3) = 4
  2386.       MEM(4) = MEMSIZ - 3
  2387.       MEM(5) = 0
  2388.  
  2389.       MACTBL = MKTABL(1)
  2390.  
  2391.       END
  2392. C------------------------------------------------
  2393. C
  2394. C  ENTER A DEFINITION INTO THE DEFINITION TABLE. NOTE
  2395. C  THAT IF THE DEFINITION ALREADY EXISTS THEN THE SPACE
  2396. C  ASSOCIATED WITH IT IS FIRST FREED.
  2397. C
  2398.       SUBROUTINE ENTDEF(NAME,DEFN)
  2399.  
  2400.       INTEGER NAME(*),DEFN(*),LOCN(2)
  2401.       INTEGER I
  2402.       INTEGER LENGTH,DSGET
  2403.       LOGICAL LOOKUP
  2404. C---------------------------------------------------------
  2405. C    TOOLPACK/1    Release: 2.5
  2406. C---------------------------------------------------------
  2407.       INTEGER MACTBL, MEMSIZ
  2408.       PARAMETER (MEMSIZ = 2500)
  2409.       INTEGER MEM(MEMSIZ)
  2410.       COMMON/CDSMEM/MEM, MACTBL
  2411.  
  2412.       SAVE
  2413.  
  2414.       IF (LOOKUP(NAME,LOCN,MACTBL)) CALL DSFREE(LOCN(1))
  2415.       LOCN(1) = DSGET(LENGTH(DEFN)+1)
  2416.       CALL ENTER(NAME,LOCN,MACTBL)
  2417.  
  2418.       I = 1
  2419.   100 CONTINUE
  2420.       IF (DEFN(I).NE.129) THEN
  2421.           MEM(LOCN(1)) = DEFN(I)
  2422.           LOCN(1) = LOCN(1) + 1
  2423.           I = I + 1
  2424.           GO TO 100
  2425.       END IF
  2426.       MEM(LOCN(1)) = 129
  2427.  
  2428.       END
  2429. C------------------------------------------------
  2430.       LOGICAL FUNCTION LUDEF(NAME,DEFN)
  2431.  
  2432.       INTEGER NAME(*),DEFN(*),LOCN(2)
  2433.       INTEGER I
  2434.       LOGICAL LOOKUP
  2435. C---------------------------------------------------------
  2436. C    TOOLPACK/1    Release: 2.5
  2437. C---------------------------------------------------------
  2438.       INTEGER MACTBL, MEMSIZ
  2439.       PARAMETER (MEMSIZ = 2500)
  2440.       INTEGER MEM(MEMSIZ)
  2441.       COMMON/CDSMEM/MEM, MACTBL
  2442.  
  2443.       SAVE
  2444.  
  2445.       IF (.NOT.LOOKUP(NAME,LOCN,MACTBL)) THEN
  2446.           DEFN(1) = 129
  2447.           LUDEF = .FALSE.
  2448.       ELSE
  2449.  
  2450.           I = 1
  2451.   100     CONTINUE
  2452.           IF (MEM(LOCN(1)).NE.129) THEN
  2453.               DEFN(I) = MEM(LOCN(1))
  2454.               LOCN(1) = LOCN(1) + 1
  2455.               I = I + 1
  2456.               GO TO 100
  2457.           END IF
  2458.           DEFN(I) = 129
  2459.           LUDEF = .TRUE.
  2460.       END IF
  2461.  
  2462.       END
  2463. C------------------------------------------------
  2464.       SUBROUTINE DSFREE(BLOCK)
  2465.  
  2466.       INTEGER BLOCK,P0,P,Q,N
  2467. C---------------------------------------------------------
  2468. C    TOOLPACK/1    Release: 2.5
  2469. C---------------------------------------------------------
  2470.       INTEGER MACTBL, MEMSIZ
  2471.       PARAMETER (MEMSIZ = 2500)
  2472.       INTEGER MEM(MEMSIZ)
  2473.       COMMON/CDSMEM/MEM, MACTBL
  2474.  
  2475.       SAVE
  2476.  
  2477.       P0 = BLOCK - 2
  2478.       N = MEM(P0)
  2479.       Q = 2
  2480.   100 CONTINUE
  2481.  
  2482.       P = MEM(Q+1)
  2483.       IF (P.NE.0 .AND. P.LE.P0) THEN
  2484.           Q = P
  2485.           GO TO 100
  2486.       END IF
  2487.  
  2488.       IF (Q+MEM(Q).GT.P0) CALL ERROR(
  2489.      +                     '[ISTRF: ATTEMPT TO FREE UNALLOCATED BLOCK].'
  2490.      +                               )
  2491.  
  2492.       IF (P0+N.EQ.P .AND. P.NE.0) THEN
  2493.           N = N + MEM(P)
  2494.           MEM(P0+1) = MEM(P+1)
  2495.       ELSE
  2496.           MEM(P0+1) = P
  2497.       END IF
  2498.  
  2499.       IF (Q+MEM(Q).EQ.P0) THEN
  2500.           MEM(Q) = MEM(Q) + N
  2501.           MEM(Q+1) = MEM(P0+1)
  2502.       ELSE
  2503.           MEM(Q+1) = P0
  2504.           MEM(P0) = N
  2505.       END IF
  2506.  
  2507.       END
  2508. C------------------------------------------------
  2509.       INTEGER FUNCTION DSGET(WIDTH)
  2510.  
  2511.       INTEGER WIDTH,POINT,OLDPNT,LINK,NEED,LEFT
  2512. C---------------------------------------------------------
  2513. C    TOOLPACK/1    Release: 2.5
  2514. C---------------------------------------------------------
  2515.       INTEGER MACTBL, MEMSIZ
  2516.       PARAMETER (MEMSIZ = 2500)
  2517.       INTEGER MEM(MEMSIZ)
  2518.       COMMON/CDSMEM/MEM, MACTBL
  2519.  
  2520.       SAVE
  2521.  
  2522.       NEED = WIDTH + 2
  2523.       OLDPNT = 2
  2524.   100 CONTINUE
  2525.  
  2526.       POINT = MEM(OLDPNT+1)
  2527.       IF (POINT.EQ.0) CALL ERROR('[ISTRF: OUT OF STORAGE].')
  2528.  
  2529.       IF (MEM(POINT).LT.NEED) THEN
  2530.           OLDPNT = POINT
  2531.           GO TO 100
  2532.       END IF
  2533.  
  2534.       LEFT = MEM(POINT) - NEED
  2535.  
  2536.       IF (LEFT.GE.8) THEN
  2537.           MEM(POINT) = LEFT
  2538.           LINK = POINT + LEFT
  2539.           MEM(LINK) = NEED
  2540.       ELSE
  2541.           MEM(OLDPNT+1) = MEM(POINT+1)
  2542.           LINK = POINT
  2543.       END IF
  2544.  
  2545.       DSGET = LINK + 2
  2546.  
  2547.       END
  2548. C------------------------------------------------
  2549.       SUBROUTINE ENTER(SYMBOL,INFO,ST)
  2550.  
  2551.       INTEGER SYMBOL(*),INFO(*)
  2552.       INTEGER ST,I,NODSIZ,J,NODE,PRED
  2553.       INTEGER LENGTH,DSGET
  2554.       LOGICAL STLU
  2555. C---------------------------------------------------------
  2556. C    TOOLPACK/1    Release: 2.5
  2557. C---------------------------------------------------------
  2558.       INTEGER MACTBL, MEMSIZ
  2559.       PARAMETER (MEMSIZ = 2500)
  2560.       INTEGER MEM(MEMSIZ)
  2561.       COMMON/CDSMEM/MEM, MACTBL
  2562.  
  2563.       SAVE
  2564.  
  2565.       NODSIZ = MEM(ST)
  2566.       IF (.NOT.STLU(SYMBOL,NODE,PRED,ST)) THEN
  2567.           NODE = DSGET(1+NODSIZ+LENGTH(SYMBOL)+1)
  2568.           MEM(NODE) = 0
  2569.           MEM(PRED) = NODE
  2570.           I = 1
  2571.           J = NODE + 1 + NODSIZ
  2572.   100     CONTINUE
  2573.           IF (SYMBOL(I).NE.129) THEN
  2574.               MEM(J) = SYMBOL(I)
  2575.               I = I + 1
  2576.               J = J + 1
  2577.               GO TO 100
  2578.           END IF
  2579.           MEM(J) = 129
  2580.       END IF
  2581.  
  2582.       I = 1
  2583.   200 CONTINUE
  2584.       IF (I.LE.NODSIZ) THEN
  2585.           J = NODE + 1 + I - 1
  2586.           MEM(J) = INFO(I)
  2587.           I = I + 1
  2588.           GO TO 200
  2589.       END IF
  2590.  
  2591.       END
  2592. C------------------------------------------------
  2593. C
  2594. C  SEE IF A DEFINITION ALREADY EXISTS FOR THE SPECIFIED SYMBOL
  2595. C
  2596.       LOGICAL FUNCTION LOOKUP(SYMBOL,INFO,ST)
  2597.  
  2598.       INTEGER SYMBOL(*),INFO(*)
  2599.       INTEGER ST,I,NODSIZ,KLUGE,NODE,PRED
  2600.       LOGICAL STLU
  2601. C---------------------------------------------------------
  2602. C    TOOLPACK/1    Release: 2.5
  2603. C---------------------------------------------------------
  2604.       INTEGER MACTBL, MEMSIZ
  2605.       PARAMETER (MEMSIZ = 2500)
  2606.       INTEGER MEM(MEMSIZ)
  2607.       COMMON/CDSMEM/MEM, MACTBL
  2608.  
  2609.       SAVE
  2610.  
  2611.       IF (.NOT.STLU(SYMBOL,NODE,PRED,ST)) THEN
  2612.           LOOKUP = .FALSE.
  2613.       ELSE
  2614.  
  2615.           NODSIZ = MEM(ST)
  2616.           I = 1
  2617.   100     CONTINUE
  2618.  
  2619.           IF (I.LE.NODSIZ) THEN
  2620.               KLUGE = NODE + 1 - 1 + I
  2621.               INFO(I) = MEM(KLUGE)
  2622.               I = I + 1
  2623.               GO TO 100
  2624.           END IF
  2625.  
  2626.           LOOKUP = .TRUE.
  2627.       END IF
  2628.  
  2629.       END
  2630. C------------------------------------------------
  2631. C
  2632. C  SAVE SPACE FOR THE HASH TABLE
  2633. C
  2634.       INTEGER FUNCTION MKTABL(NODSIZ)
  2635.  
  2636.       INTEGER NODSIZ,ST,I
  2637.       INTEGER DSGET
  2638. C---------------------------------------------------------
  2639. C    TOOLPACK/1    Release: 2.5
  2640. C---------------------------------------------------------
  2641.       INTEGER MACTBL, MEMSIZ
  2642.       PARAMETER (MEMSIZ = 2500)
  2643.       INTEGER MEM(MEMSIZ)
  2644.       COMMON/CDSMEM/MEM, MACTBL
  2645.  
  2646.       SAVE
  2647.  
  2648.       ST = DSGET(43+1)
  2649.       MEM(ST) = NODSIZ
  2650.       MKTABL = ST
  2651.  
  2652.       DO 100 I = ST + 1,ST + 43
  2653.           MEM(I) = 0
  2654.   100 CONTINUE
  2655.  
  2656.       END
  2657. C------------------------------------------------
  2658. C
  2659. C  SEE IF THE SPECIFIED SYMBOL ALREADY EXISTS IN THE TABLE.
  2660. C  ST = START OF HASH TABLE.
  2661. C
  2662.       LOGICAL FUNCTION STLU(SYMBOL,NODE,PRED,ST)
  2663.  
  2664.       INTEGER SYMBOL(*)
  2665.       INTEGER NODE,PRED,ST
  2666.       INTEGER HASH,I,J,NODSIZ
  2667. C---------------------------------------------------------
  2668. C    TOOLPACK/1    Release: 2.5
  2669. C---------------------------------------------------------
  2670.       INTEGER MACTBL, MEMSIZ
  2671.       PARAMETER (MEMSIZ = 2500)
  2672.       INTEGER MEM(MEMSIZ)
  2673.       COMMON/CDSMEM/MEM, MACTBL
  2674.  
  2675.       SAVE
  2676.  
  2677.       NODSIZ = MEM(ST)
  2678.       HASH = 0
  2679.       I = 1
  2680.   100 CONTINUE
  2681.  
  2682.       IF (SYMBOL(I).NE.129) THEN
  2683.           HASH = HASH + SYMBOL(I)
  2684.           I = I + 1
  2685.           GO TO 100
  2686.       END IF
  2687.  
  2688.       HASH = MOD(HASH,43) + 1
  2689.       PRED = ST + HASH
  2690.       NODE = MEM(PRED)
  2691.   200 CONTINUE
  2692.  
  2693.       IF (NODE.NE.0) THEN
  2694.           I = 1
  2695.           J = NODE + 1 + NODSIZ
  2696.   300     CONTINUE
  2697.           IF (SYMBOL(I).EQ.MEM(J)) THEN
  2698.               IF (SYMBOL(I).EQ.129) THEN
  2699.                   GO TO 400
  2700.               ELSE
  2701.                   I = I + 1
  2702.                   J = J + 1
  2703.                   GO TO 300
  2704.               END IF
  2705.           END IF
  2706.  
  2707.           PRED = NODE
  2708.           NODE = MEM(PRED)
  2709.           GO TO 200
  2710.       END IF
  2711.  
  2712.       STLU = .FALSE.
  2713.       RETURN
  2714.   400 STLU = .TRUE.
  2715.  
  2716.       END
  2717.