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 / istan / ANLIB0.MAC.f next >
Encoding:
Text File  |  1989-03-04  |  24.8 KB  |  688 lines
  1. C---------------------------------------------------------
  2. C    TOOLPACK/1    Release: 2.3
  3. C---------------------------------------------------------
  4. C---------------------------------------------------------
  5. C    TOOLPACK/1    Release: 2.3
  6. C---------------------------------------------------------
  7. C ----------------------------------------------------------------------
  8. C
  9. C       O U T T X T   -   Output Fortran-77 character string text
  10. C
  11.  
  12.         SUBROUTINE OUTTXT(TEXT,IOD)
  13.         CHARACTER*(*) TEXT
  14.         INTEGER IOD
  15.  
  16.         INTEGER I,L
  17.  
  18.         INTRINSIC INDEX
  19.  
  20.         EXTERNAL ZPUTCH,ZCHOUT
  21.  
  22.         L=1
  23.  100    I=INDEX(TEXT(L:),'.')
  24.         IF (I.EQ.0) THEN
  25.             CALL ZCHOUT(TEXT(L:),IOD)
  26.         ELSE
  27.             IF (I.GT.1) CALL ZCHOUT(TEXT(L:L+I-2),IOD)
  28.             CALL ZPUTCH('.',IOD)
  29.             L=L+I
  30.             IF (L.LE.LEN(TEXT)) GOTO 100
  31.         END IF
  32.  
  33.         END
  34. C ----------------------------------------------------------------------
  35. C
  36. C       O U T M S G   -   Output a line of Fortran-77 character string
  37. C
  38.  
  39.         SUBROUTINE OUTMSG(TEXT,IOD)
  40.         CHARACTER*(*) TEXT
  41.         INTEGER IOD
  42.  
  43.         EXTERNAL PUTCH
  44.  
  45.         CALL OUTTXT(TEXT,IOD)
  46.         CALL PUTCH(10,IOD)
  47.  
  48.         END
  49. C ----------------------------------------------------------------------
  50. C
  51. C       C C O P Y   -   Copy a character array to another
  52. C
  53.  
  54.         SUBROUTINE CCOPY(CA1,LGTH,CA2)
  55.         CHARACTER CA1(*),CA2(*)
  56.         INTEGER LGTH
  57.  
  58.         INTEGER I
  59.  
  60.         DO 100 I=1,LGTH
  61.  100        CA2(I)=CA1(I)
  62.  
  63.         END
  64. C ----------------------------------------------------------------------
  65. C
  66. C       I N S O U T   -   Output a statement to the scratch
  67. C                         instrumentation file.
  68. C
  69.  
  70.         SUBROUTINE INSOUT
  71.  
  72. C---------------------------------------------------------
  73. C    TOOLPACK/1    Release: 2.3
  74. C---------------------------------------------------------
  75.         COMMON/TOKENS/TOKTYP,TOKLEN,TXTPTR,TOKEN,NTOKSS,ISTTXT,ISTPTR,
  76.      +                MAXICH
  77.         INTEGER TOKTYP(800),TOKLEN(800),TXTPTR(800),
  78.      +          TOKEN,NTOKSS,ISTTXT(1322+800),ISTPTR(800),
  79.      +          MAXICH
  80.  
  81.         SAVE /TOKENS/
  82.  
  83. C
  84. C TOKTYP = array of token types for current statement
  85. C TOKLEN = parallel array of lengths of associated text strings
  86. C TXTPTR = parallel array of pointers into ISTMG character array of text
  87. C TOKEN = Current token number within statement being processed
  88. C NTOKSS = Number of tokens in statement
  89. C ISTTXT = IST text of token as read in before being converted by ZTOKTX
  90. C ISTPTR = parallel array (to TOKTYP) of pointers into ISTTXT
  91. C MAXICH = Last character used in ISTTXT array
  92. C
  93.  
  94.         CALL SENDTK(1,NTOKSS)
  95.         CALL SEND
  96.  
  97.         END
  98. C ----------------------------------------------------------------------
  99. C
  100. C       W R I T O K   -   Write a token to the annotated token stream
  101. C
  102.  
  103.         SUBROUTINE WRITOK(TYPE,CHAR)
  104.         INTEGER TYPE
  105.         CHARACTER*(*) CHAR
  106.  
  107. C---------------------------------------------------------
  108. C    TOOLPACK/1    Release: 2.3
  109. C---------------------------------------------------------
  110.         COMMON/IO/IODINS,IODSTS,IODSUM,IODSCR,TKIDES,TKODES
  111.         INTEGER IODINS,IODSTS,IODSUM,IODSCR,TKIDES,TKODES
  112.  
  113.         SAVE /IO/
  114.  
  115.  
  116.         INTEGER TEXT(134),LENGTH
  117.  
  118.         INTRINSIC LEN
  119.  
  120.         EXTERNAL ZFTOI,ZTOKWR
  121.  
  122.         LENGTH=LEN(CHAR)
  123.         CALL ZFTOI(CHAR,1,LENGTH,TEXT,.FALSE.)
  124.         CALL ZTOKWR(TYPE,LENGTH,TEXT,TKODES)
  125.  
  126.         END
  127. C ----------------------------------------------------------------------
  128. C
  129. C       S E N D C H   -   Send a character string to the (instrumented)
  130. C                         output buffer
  131. C
  132.  
  133.         SUBROUTINE SENDCH(CH)
  134.         CHARACTER*(*) CH
  135.  
  136. C---------------------------------------------------------
  137. C    TOOLPACK/1    Release: 2.3
  138. C---------------------------------------------------------
  139. C                  CONTROL VARIABLES
  140.       COMMON / CNTRLC  /    IERRG,       IFTYPG,      ITYPEG,
  141.      *         IUNITG,      JERRG,       KERRG,       LABFLG,
  142.      *         LINEG,       LTYPEG,      NBUFFG,      NTOKG,
  143.      *         NTOK2G,      NTOK3G,      NTOK4G,      NCOMG,
  144.      *         NCRTNG,      NDDICG,      NEDICG,      NLABG,
  145.      *         NMASRG,      NMSEG,       NRDICG,      NRTNG,
  146.      *         NSTMG,       NTREEG,      NTYPEG
  147.  
  148.         INTEGER IERRG,IFTYPG,ITYPEG,IUNITG,JERRG,KERRG,LABFLG,LINEG,
  149.      +          LTYPEG,NBUFFG,NTOKG,NTOK2G,NTOK3G,NTOK4G,NCOMG,NCRTNG,
  150.      +          NDDICG,NEDICG,NLABG,NMASRG,NMSEG,NRDICG,NRTNG,NSTMG,
  151.      +          NTREEG,NTYPEG
  152.  
  153.         SAVE /CNTRLC/
  154.  
  155. C---------------------------------------------------------
  156. C    TOOLPACK/1    Release: 2.3
  157. C---------------------------------------------------------
  158. C Character variables and arrays, except for dictionaries & VNAMEG
  159.         INTEGER MAXCMG
  160.         PARAMETER(MAXCMG=30)
  161.         COMMON /CHARC/ IBUFFG,ICARDG,ICOMG,ISTMG,NAMEG
  162.  
  163.         CHARACTER IBUFFG(1326),ICARDG(72),ISTMG(1326)
  164.         CHARACTER*6 NAMEG
  165.         CHARACTER*72 ICOMG(MAXCMG)
  166.  
  167.         SAVE /CHARC/
  168.  
  169.         INTEGER I
  170.  
  171.         INTRINSIC LEN
  172.  
  173.         DO 100 I=1,LEN(CH)
  174.             NBUFFG=NBUFFG+1
  175.             IBUFFG(NBUFFG)=CH(I:I)
  176. 100     CONTINUE
  177.  
  178.         END
  179. C ----------------------------------------------------------------------
  180. C
  181. C       S E N D T K   -   Send a string of tokens to the instr buffer
  182. C
  183. C       This routine also does the conversion of CALL ZQUIT/ERROR when
  184. C       in TIE mode, as it is easiest done here.
  185. C
  186.  
  187.         SUBROUTINE SENDTK(FROM,TO)
  188.         INTEGER FROM,TO
  189.  
  190. C---------------------------------------------------------
  191. C    TOOLPACK/1    Release: 2.3
  192. C---------------------------------------------------------
  193. C Character variables and arrays, except for dictionaries & VNAMEG
  194.         INTEGER MAXCMG
  195.         PARAMETER(MAXCMG=30)
  196.         COMMON /CHARC/ IBUFFG,ICARDG,ICOMG,ISTMG,NAMEG
  197.  
  198.         CHARACTER IBUFFG(1326),ICARDG(72),ISTMG(1326)
  199.         CHARACTER*6 NAMEG
  200.         CHARACTER*72 ICOMG(MAXCMG)
  201.  
  202.         SAVE /CHARC/
  203. C---------------------------------------------------------
  204. C    TOOLPACK/1    Release: 2.3
  205. C---------------------------------------------------------
  206. C                  CONTROL VARIABLES
  207.       COMMON / CNTRLC  /    IERRG,       IFTYPG,      ITYPEG,
  208.      *         IUNITG,      JERRG,       KERRG,       LABFLG,
  209.      *         LINEG,       LTYPEG,      NBUFFG,      NTOKG,
  210.      *         NTOK2G,      NTOK3G,      NTOK4G,      NCOMG,
  211.      *         NCRTNG,      NDDICG,      NEDICG,      NLABG,
  212.      *         NMASRG,      NMSEG,       NRDICG,      NRTNG,
  213.      *         NSTMG,       NTREEG,      NTYPEG
  214.  
  215.         INTEGER IERRG,IFTYPG,ITYPEG,IUNITG,JERRG,KERRG,LABFLG,LINEG,
  216.      +          LTYPEG,NBUFFG,NTOKG,NTOK2G,NTOK3G,NTOK4G,NCOMG,NCRTNG,
  217.      +          NDDICG,NEDICG,NLABG,NMASRG,NMSEG,NRDICG,NRTNG,NSTMG,
  218.      +          NTREEG,NTYPEG
  219.  
  220.         SAVE /CNTRLC/
  221.  
  222. C---------------------------------------------------------
  223. C    TOOLPACK/1    Release: 2.3
  224. C---------------------------------------------------------
  225. C                  LOGICAL VARIABLES
  226.       COMMON / LOGIC   /    ARITHG,      ASSRTG,      BLKDTG,
  227.      *         CARD1G,      CGOTOG,      ENTRYG,      EXECG,
  228.      *         HISTG,       IEOFG,       IFDOG,       INSRTG,
  229.      *         MAING,       SEGMTG,      STOPG,       TRACEG,
  230.      *         TREEG
  231.       LOGICAL  ARITHG,      ASSRTG,      BLKDTG,      CARD1G,
  232.      *         CGOTOG,      ENTRYG,      EXECG,       HISTG,
  233.      *         IEOFG,       IFDOG,       INSRTG,      MAING,
  234.      *         SEGMTG,      STOPG,       TRACEG,      TREEG
  235.  
  236.         SAVE /LOGIC/
  237.  
  238. C---------------------------------------------------------
  239. C    TOOLPACK/1    Release: 2.3
  240. C---------------------------------------------------------
  241. C Option Settings
  242.         COMMON /OPTSC/ INHSTG,INTRAG,ITHSTG,ITLSTG,ITTRAG,MCIRCG,
  243.      +                 MTREQG,TIEG,ITRUNG
  244.  
  245.         INTEGER INHSTG,INTRAG,ITHSTG,ITLSTG,ITTRAG,MCIRCG,MTREQG,
  246.      +          ITRUNG
  247.         LOGICAL TIEG
  248.  
  249.         SAVE /OPTSC/
  250.  
  251. C---------------------------------------------------------
  252. C    TOOLPACK/1    Release: 2.3
  253. C---------------------------------------------------------
  254.         COMMON/TOKENS/TOKTYP,TOKLEN,TXTPTR,TOKEN,NTOKSS,ISTTXT,ISTPTR,
  255.      +                MAXICH
  256.         INTEGER TOKTYP(800),TOKLEN(800),TXTPTR(800),
  257.      +          TOKEN,NTOKSS,ISTTXT(1322+800),ISTPTR(800),
  258.      +          MAXICH
  259.  
  260.         SAVE /TOKENS/
  261.  
  262. C
  263. C TOKTYP = array of token types for current statement
  264. C TOKLEN = parallel array of lengths of associated text strings
  265. C TXTPTR = parallel array of pointers into ISTMG character array of text
  266. C TOKEN = Current token number within statement being processed
  267. C NTOKSS = Number of tokens in statement
  268. C ISTTXT = IST text of token as read in before being converted by ZTOKTX
  269. C ISTPTR = parallel array (to TOKTYP) of pointers into ISTTXT
  270. C MAXICH = Last character used in ISTTXT array
  271. C
  272. C---------------------------------------------------------
  273. C    TOOLPACK/1    Release: 2.3
  274. C---------------------------------------------------------
  275.         COMMON/ANVNAM/VNAMEG
  276.         CHARACTER*5 VNAMEG
  277.         SAVE/ANVNAM/
  278. C---------------------------------------------------------
  279. C    TOOLPACK/1    Release: 2.4
  280. C---------------------------------------------------------
  281. C
  282. C  TKLAST = LAST TOKEN NUMBER
  283. C
  284.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  285.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  286.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  287.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  288.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  289.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  290.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  291.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  292.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  293.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  294.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  295.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  296.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  297.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  298.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  299.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  300.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  301.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  302.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  303.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  304.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  305.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  306.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  307.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  308.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  309.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  310.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  311.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  312.  
  313.  
  314.         INTEGER BUFF(134),STATUS,I,J,FIRST
  315.         CHARACTER*6 NAMEL
  316.         LOGICAL TEST
  317.  
  318.         CHARACTER*6 NAME
  319.  
  320.         INTEGER LENGTH,ZTOKTX
  321.         CHARACTER ZCITOC
  322.         EXTERNAL LENGTH,ZCITOC,ZTOKTX
  323.  
  324. C
  325. C Special handling for possible labels on first line
  326. C
  327.         IF (FROM.EQ.1 .AND. TOKTYP(FROM).EQ.TDCNST) THEN
  328.             FIRST=2
  329.             DO 20 I=1,TOKLEN(1)
  330.  20             IBUFFG(I)=ZCITOC(ISTTXT(ISTPTR(1)+I-1),IBUFFG(I))
  331.             DO 40 I=TOKLEN(1)+1,6
  332.  40             IBUFFG(I)=' '
  333.         ELSE IF (NBUFFG.LT.7) THEN
  334.             FIRST=FROM
  335.             DO 60 I=1,6
  336.  60             IBUFFG(I)=' '
  337.         ELSE
  338.             FIRST=FROM
  339.         END IF
  340.         NBUFFG=MAX(NBUFFG,6)
  341. C
  342. C Now output the ordinary stuff (if any)
  343. C
  344.         DO 200 I=FIRST,TO
  345. C First check the token against ZQUIT and ERROR if in TIE mode
  346.             TEST=TOKTYP(I).EQ.TNAME .AND. I.GT.FIRST .AND. TIEG
  347.             IF (TEST) THEN
  348.                 NAMEL=NAME(I)
  349.                 TEST=(NAMEL.EQ.'ZQUIT' .OR. NAMEL.EQ.'ERROR' .OR.
  350.      +                NAMEL.EQ.'ZEXIT' .OR.
  351.      +                (TRACEG .AND. NAMEL.EQ.'ZINIT')) .AND.
  352.      +                TOKTYP(I-1).EQ.TCALL
  353.                 IF (TEST) THEN
  354.                     IF (NAMEL.EQ.'ZQUIT') THEN
  355.                         CALL SENDCH('R'//VNAMEG)
  356.                     ELSE IF (NAMEL.EQ.'ERROR') THEN
  357.                         CALL SENDCH('E'//VNAMEG)
  358.                     ELSE IF (NAMEL.EQ.'ZEXIT') THEN
  359.                         CALL SENDCH('W'//VNAMEG)
  360.                         IF (TRACEG .AND. ITTRAG.NE.1 .AND.
  361.      +                      ITTRAG.NE.3) CALL ERROR(
  362.      +'Cannot handle ZEXIT when TRACE-ing to a file')
  363.                     ELSE IF (NAMEL.EQ.'ZINIT') THEN
  364.                         CALL SENDCH('X'//VNAMEG)
  365.                     END IF
  366.                 END IF
  367.             END IF
  368.             IF (.NOT.TEST) THEN
  369.                 STATUS=ZTOKTX(TOKTYP(I),TOKLEN(I),ISTTXT(ISTPTR(I)),
  370.      +                        BUFF)
  371.                 DO 100 J=1,LENGTH(BUFF)
  372.                     NBUFFG=NBUFFG+1
  373.  100                IBUFFG(NBUFFG)=ZCITOC(BUFF(J),IBUFFG(NBUFFG))
  374.             END IF
  375.  200    CONTINUE
  376.  
  377.         END
  378. C ----------------------------------------------------------------------
  379. C
  380. C       S E N D I   -   Send an integer to the instrumented buffer
  381. C
  382.  
  383.         SUBROUTINE SENDI(INT)
  384.         INTEGER INT
  385.  
  386.         CHARACTER*5 STRING
  387.         INTEGER I
  388.  
  389.         WRITE(STRING,9000) INT
  390.         I=0
  391.  100    I=I+1
  392.         IF (STRING(I:I).EQ.' ') GOTO 100
  393.         CALL SENDCH(STRING(I:))
  394.  
  395. 9000    FORMAT(SS,I5)
  396.         END
  397. C ----------------------------------------------------------------------
  398. C
  399. C       S E N D   -   Send the instrumented output buffer to the file
  400. C
  401.  
  402.         SUBROUTINE SEND
  403.  
  404. C---------------------------------------------------------
  405. C    TOOLPACK/1    Release: 2.3
  406. C---------------------------------------------------------
  407.         COMMON/IO/IODINS,IODSTS,IODSUM,IODSCR,TKIDES,TKODES
  408.         INTEGER IODINS,IODSTS,IODSUM,IODSCR,TKIDES,TKODES
  409.  
  410.         SAVE /IO/
  411.  
  412. C---------------------------------------------------------
  413. C    TOOLPACK/1    Release: 2.3
  414. C---------------------------------------------------------
  415. C Character variables and arrays, except for dictionaries & VNAMEG
  416.         INTEGER MAXCMG
  417.         PARAMETER(MAXCMG=30)
  418.         COMMON /CHARC/ IBUFFG,ICARDG,ICOMG,ISTMG,NAMEG
  419.  
  420.         CHARACTER IBUFFG(1326),ICARDG(72),ISTMG(1326)
  421.         CHARACTER*6 NAMEG
  422.         CHARACTER*72 ICOMG(MAXCMG)
  423.  
  424.         SAVE /CHARC/
  425. C---------------------------------------------------------
  426. C    TOOLPACK/1    Release: 2.3
  427. C---------------------------------------------------------
  428. C                  CONTROL VARIABLES
  429.       COMMON / CNTRLC  /    IERRG,       IFTYPG,      ITYPEG,
  430.      *         IUNITG,      JERRG,       KERRG,       LABFLG,
  431.      *         LINEG,       LTYPEG,      NBUFFG,      NTOKG,
  432.      *         NTOK2G,      NTOK3G,      NTOK4G,      NCOMG,
  433.      *         NCRTNG,      NDDICG,      NEDICG,      NLABG,
  434.      *         NMASRG,      NMSEG,       NRDICG,      NRTNG,
  435.      *         NSTMG,       NTREEG,      NTYPEG
  436.  
  437.         INTEGER IERRG,IFTYPG,ITYPEG,IUNITG,JERRG,KERRG,LABFLG,LINEG,
  438.      +          LTYPEG,NBUFFG,NTOKG,NTOK2G,NTOK3G,NTOK4G,NCOMG,NCRTNG,
  439.      +          NDDICG,NEDICG,NLABG,NMASRG,NMSEG,NRDICG,NRTNG,NSTMG,
  440.      +          NTREEG,NTYPEG
  441.  
  442.         SAVE /CNTRLC/
  443.  
  444.  
  445.         INTEGER I
  446.         CHARACTER LINE1*72,LINE*72,LYNE(72)
  447.         EQUIVALENCE (LINE1,IBUFFG),(LINE,LYNE)
  448.  
  449.         IF (NBUFFG.LT.72) THEN
  450.             CALL OUTMSG(LINE1(1:NBUFFG),IODSCR)
  451.         ELSE
  452.             CALL OUTMSG(LINE1,IODSCR)
  453.             DO 100 I=73,NBUFFG,66
  454.                 LINE='     +'
  455.                 CALL CCOPY(IBUFFG(I),MIN(66,NBUFFG-I+1),LYNE(7))
  456.                 CALL OUTMSG(LINE,IODSCR)
  457.  100        CONTINUE
  458.         END IF
  459.         NBUFFG=0
  460.         LINE1=' '
  461.  
  462.         END
  463. C ----------------------------------------------------------------------
  464. C
  465. C       U N L A B L   -   Remove the label token from a line
  466. C
  467.  
  468.         SUBROUTINE UNLABL
  469.  
  470. C---------------------------------------------------------
  471. C    TOOLPACK/1    Release: 2.3
  472. C---------------------------------------------------------
  473.         COMMON/TOKENS/TOKTYP,TOKLEN,TXTPTR,TOKEN,NTOKSS,ISTTXT,ISTPTR,
  474.      +                MAXICH
  475.         INTEGER TOKTYP(800),TOKLEN(800),TXTPTR(800),
  476.      +          TOKEN,NTOKSS,ISTTXT(1322+800),ISTPTR(800),
  477.      +          MAXICH
  478.  
  479.         SAVE /TOKENS/
  480.  
  481. C
  482. C TOKTYP = array of token types for current statement
  483. C TOKLEN = parallel array of lengths of associated text strings
  484. C TXTPTR = parallel array of pointers into ISTMG character array of text
  485. C TOKEN = Current token number within statement being processed
  486. C NTOKSS = Number of tokens in statement
  487. C ISTTXT = IST text of token as read in before being converted by ZTOKTX
  488. C ISTPTR = parallel array (to TOKTYP) of pointers into ISTTXT
  489. C MAXICH = Last character used in ISTTXT array
  490. C
  491. C---------------------------------------------------------
  492. C    TOOLPACK/1    Release: 2.4
  493. C---------------------------------------------------------
  494. C
  495. C  TKLAST = LAST TOKEN NUMBER
  496. C
  497.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  498.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  499.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  500.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  501.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  502.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  503.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  504.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  505.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  506.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  507.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  508.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  509.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  510.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  511.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  512.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  513.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  514.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  515.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  516.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  517.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  518.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  519.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  520.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  521.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  522.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  523.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  524.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  525.  
  526. C---------------------------------------------------------
  527. C    TOOLPACK/1    Release: 2.3
  528. C---------------------------------------------------------
  529. C                  CONTROL VARIABLES
  530.       COMMON / CNTRLC  /    IERRG,       IFTYPG,      ITYPEG,
  531.      *         IUNITG,      JERRG,       KERRG,       LABFLG,
  532.      *         LINEG,       LTYPEG,      NBUFFG,      NTOKG,
  533.      *         NTOK2G,      NTOK3G,      NTOK4G,      NCOMG,
  534.      *         NCRTNG,      NDDICG,      NEDICG,      NLABG,
  535.      *         NMASRG,      NMSEG,       NRDICG,      NRTNG,
  536.      *         NSTMG,       NTREEG,      NTYPEG
  537.  
  538.         INTEGER IERRG,IFTYPG,ITYPEG,IUNITG,JERRG,KERRG,LABFLG,LINEG,
  539.      +          LTYPEG,NBUFFG,NTOKG,NTOK2G,NTOK3G,NTOK4G,NCOMG,NCRTNG,
  540.      +          NDDICG,NEDICG,NLABG,NMASRG,NMSEG,NRDICG,NRTNG,NSTMG,
  541.      +          NTREEG,NTYPEG
  542.  
  543.         SAVE /CNTRLC/
  544.  
  545.  
  546.         INTEGER I
  547.  
  548.         IF (TOKTYP(1).EQ.TDCNST) THEN
  549.             DO 100 I=2,NTOKSS
  550.                 TOKTYP(I-1)=TOKTYP(I)
  551.                 TOKLEN(I-1)=TOKLEN(I)
  552.                 TXTPTR(I-1)=TXTPTR(I)
  553.                 ISTPTR(I-1)=ISTPTR(I)
  554.  100        CONTINUE
  555.             IF (NTOKG.GT.0) NTOKG=NTOKG-1
  556.             IF (NTOK2G.GT.0) NTOK2G=NTOK2G-1
  557.             IF (NTOK3G.GT.0) NTOK3G=NTOK3G-1
  558.             IF (NTOK4G.GT.0) NTOK4G=NTOK4G-1
  559.             NTOKSS=NTOKSS-1
  560.         END IF
  561.  
  562.         END
  563. C ----------------------------------------------------------------------
  564. C
  565. C       N A M E   -   Return the name of a TNAME token as a char string
  566. C
  567.  
  568.         CHARACTER*6 FUNCTION NAME(TOKNUM)
  569.         INTEGER TOKNUM
  570.  
  571. C---------------------------------------------------------
  572. C    TOOLPACK/1    Release: 2.4
  573. C---------------------------------------------------------
  574. C
  575. C  TKLAST = LAST TOKEN NUMBER
  576. C
  577.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  578.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  579.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  580.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  581.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  582.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  583.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  584.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  585.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  586.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  587.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  588.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  589.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  590.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  591.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  592.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  593.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  594.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  595.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  596.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  597.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  598.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  599.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  600.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  601.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  602.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  603.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  604.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  605.  
  606. C---------------------------------------------------------
  607. C    TOOLPACK/1    Release: 2.3
  608. C---------------------------------------------------------
  609.         COMMON/TOKENS/TOKTYP,TOKLEN,TXTPTR,TOKEN,NTOKSS,ISTTXT,ISTPTR,
  610.      +                MAXICH
  611.         INTEGER TOKTYP(800),TOKLEN(800),TXTPTR(800),
  612.      +          TOKEN,NTOKSS,ISTTXT(1322+800),ISTPTR(800),
  613.      +          MAXICH
  614.  
  615.         SAVE /TOKENS/
  616.  
  617. C
  618. C TOKTYP = array of token types for current statement
  619. C TOKLEN = parallel array of lengths of associated text strings
  620. C TXTPTR = parallel array of pointers into ISTMG character array of text
  621. C TOKEN = Current token number within statement being processed
  622. C NTOKSS = Number of tokens in statement
  623. C ISTTXT = IST text of token as read in before being converted by ZTOKTX
  624. C ISTPTR = parallel array (to TOKTYP) of pointers into ISTTXT
  625. C MAXICH = Last character used in ISTTXT array
  626. C
  627. C---------------------------------------------------------
  628. C    TOOLPACK/1    Release: 2.3
  629. C---------------------------------------------------------
  630. C Character variables and arrays, except for dictionaries & VNAMEG
  631.         INTEGER MAXCMG
  632.         PARAMETER(MAXCMG=30)
  633.         COMMON /CHARC/ IBUFFG,ICARDG,ICOMG,ISTMG,NAMEG
  634.  
  635.         CHARACTER IBUFFG(1326),ICARDG(72),ISTMG(1326)
  636.         CHARACTER*6 NAMEG
  637.         CHARACTER*72 ICOMG(MAXCMG)
  638.  
  639.         SAVE /CHARC/
  640.  
  641.         INTEGER I
  642.  
  643.         INTRINSIC MIN
  644.  
  645.         EXTERNAL ERROR
  646.  
  647.         NAME=' '
  648.         IF (TOKTYP(TOKNUM).NE.TNAME) CALL ERROR('Invalid NAME call')
  649.         DO 100 I=1,MIN(6,TOKLEN(TOKNUM))
  650.  100        NAME(I:I)=ISTMG(TXTPTR(TOKNUM)+I-1)
  651.  
  652.         END
  653. C ----------------------------------------------------------------------
  654. C
  655. C       O U T Z F I   -   Output zero-filled integer
  656. C
  657.  
  658.         SUBROUTINE OUTZFI(NUMBER,PLACES,IOD)
  659.         INTEGER NUMBER,PLACES,IOD
  660.  
  661.         INTEGER BUFF(134)
  662.  
  663.         EXTERNAL ZITOCP
  664.  
  665.         CALL ZITOCP(NUMBER,BUFF,PLACES,48)
  666.         CALL PUTLIN(BUFF,IOD)
  667.  
  668.         END
  669. C ----------------------------------------------------------------------
  670. C
  671. C       S T R I P L   -   Return length of character string with
  672. C                         trailing spaces stripped.
  673. C
  674.  
  675.         INTEGER FUNCTION STRIPL(STRING)
  676.         CHARACTER*(*)STRING
  677.  
  678.         INTRINSIC LEN
  679.  
  680.         STRIPL=LEN(STRING)
  681.  
  682.  100    IF (STRING(STRIPL:STRIPL).EQ.' ' .AND. STRIPL.GT.1) THEN
  683.             STRIPL=STRIPL-1
  684.             GOTO 100
  685.         END IF
  686.  
  687.         END
  688.