*COMMENT
 
    A SIMPLE MACRO PROCESSOR
    THIS PROCESSOR WAS DEVELOPED AT PURDUE UNIVERSITY AS PART
    OF THE TOOLPACK PROJECT.  SUPPORT BY NSF GRANT MCS79-26310
    IS GRATEFULLY ACKNOWLEDGED.  THIS PROGRAM WAS WRITTEN
    BY WILLIAM A. WARD BASED ON AN EARLIER MACRO-PROCESSOR
    WRITTEN BY JOHN R. RICE.  THE FACILITIES & COMMENTS WERE
    ENHANCED BY CALVIN J. RIBBENS.  PLEASE REPORT ANY BUGS OR
    SUGGESTIONS TO JOHN R. RICE, COMPUTER SCIENCES DEPT. ,
    PURDUE UNIVERSITY, WEST LAFAYETTE, INDIANA 47907.
 
 
    THE PRIMARY DOCUMENTATION OF THIS PROGRAM ARE THE REPORTS:
 
  A SIMPLE MACRO PROCESSOR - USER'S GUIDE
    JOHN R. RICE AND WILLIAM A. WARD
    CSD-TR 403, PURDUE UNIVERSITY, 1982
    (REVISED APRIL, 1983)
 
  A SIMPLE MACRO PROCESSOR
    CALVIN J. RIBBENS, JOHN R. RICE AND WILLIAM A. WARD
    CSD-TR 400, PURDUE UNIVERSITY, 1982
    (REVISED APRIL, 1983)
 
 
    MACHINE READABLE VERSIONS OF THESE SHOULD BE DISTRIBUTED WITH
    THIS PROGRAM.  THE DISTRIBUTION INCLUDES A FILE OF TEST INPUT
    WHICH EXTENSIVELY EXCERCISES THIS PROCESOR; IT SHOULD BE
    USED TO TEST ANY INSTALLATION.
 
    THE FOLLOWING COMMENTS PERTAIN TO HOW TO OBTAIN A WORKING
    FORTRAN VERSION OF THE MACRO-PROCESSOR FROM THIS MASTER
    TEMPLATE OF IT.
 
    YOUR VERSION OF THE TEMPLATE PROCESSOR MAY BE TUNED
    BY SETTING THE FOLLOWING TEMPLATE VARIABLES TO APPROPRIATE
    VALUES AND THEN APPLYING THE BASIC PROCESSOR TO THE FOLLOWING
    TEMPLATE.
 
    LIBRARY - IF .TRUE., ONLY THOSE ROUTINES NEEDED FOR A TEMPLATE
        PROCESSOR LIBRARY WILL BE INCLUDED.  THE USER MUST
        SUPPLY A MAIN PROGRAM WHICH CALLS TPDRV, THE DRIVER
        ROUTINE.  IF .FALSE., A MAIN PROGRAM WILL BE SUPPLIED
        SO THAT A COMPLETE STAND-ALONE VERSION OF THE PROCESSOR
        MAY BE CREATED.
    ICBDIM  - THE DIMENSION OF THE ARRAY CBUFFR.
    ICSDIM  - THE DIMENSION OF THE ARRAY CSTORE
    IHADIM  - THE DIMENSION OF THE ARRAY IHASH.
        THIS SHOULD BE A PRIME NUMBER.
    ISTDIM  - THE DIMENSION OF THE ARRAY ISTORE.
        SHOULD BE LESS THAN ICSDIM.
    CSTAR1  - IF .TRUE., FORTRAN 77 DECLARATIONS
        OF THE FORM CHARACTER*1 ARE USED
        INSTEAD OF INTEGER DECLARATIONS.
    NOPACK  - IF .TRUE., ALL REFERENCES TO THE ARRAY
        CSTORE WILL BE DIRECT (IN-LINE) INSTEAD
        OF BEING FORCED THROUGH SUBROUTINES.
    TESTCH  - IF .TRUE., CHARACTER TESTING USED TO CHECK FOR
        ALPHABETIC AND NUMERIC IS PERFORMED USING IN-LINE
        IF STATEMENTS INSTEAD OF BEING ISOLATED IN SEPARATE
        SUBROUTINES.  USE OF IN-LINE IF STATEMENTS
        ASSUMES THE DIGITS 0 TO 9 AND THE LETTERS A TO Z
        ARE REPRESENTED BY CONTIGUOUS CHARACTER CODES.  IF
        THIS IS NOT THE CASE, INSTALLER SHOULD SET
        TESTCH=.FALSE. AND MODIFY ROUTINES UTCHKA, UTCHKN,
        AND UTCHKS APPROPRIATELY.
    UNIX    - PRODUCE A UNIX COMPATIBLE VERSION.
    CDC     - IF .TRUE., A PURDUE CDC COMPATIBLE
        VERSION IS PRODUCED.
    DEBUG   - IF .TRUE., MNF TRACE STATEMENTS WILL
        BE INSERTED. THIS SHOULD ONLY BE USED
        IF CDC = .TRUE.
    SHORTB  - IF .TRUE. AND CDC = .TRUE., SHORT FILE
        BUFFERS WILL BE USED.
    STATS   - IF .TRUE., MNF TIMING STATEMENTS WILL
        BE INSERTED. THIS SHOULD ONLY BE USED
        IF CDC = .TRUE.
 
*ENDCOM
*OPTION(LISTI = .FALSE.)
*OPTION(LISTO = .FALSE.)
*OPTION(LCOL1 = .TRUE. )
*COMMENT
 
    IF LIBRARY = .TRUE., THE USER SUPPLIES A MAIN PROGRAM WHICH
    WILL SET THE DIMENSIONS OF CBUFFR, CSTORE, IHASH, AND ISTORE.
 
*ENDCOM
*SET (LIBRARY = .FALSE.)
*IF(LIBRARY)
*SET ( ICBDIM = 1 )
*SET ( ICSDIM = 1 )
*SET ( IHADIM = 1 )
*SET ( ISTDIM = 1 )
*ELSE
*SET ( ICBDIM =  2000 )
*SET ( ICSDIM = 20000 )
*SET ( IHADIM =   601 )
*SET ( ISTDIM =  6000 )
*ENDIF
*SET ( CSTAR1 = .FALSE.)
*SET ( NOPACK = .TRUE. )
*SET ( TESTCH = .TRUE. )
*SET ( UNIX   = .TRUE. )
*SET ( CDC    = .FALSE.)
*SET ( DEBUG  = .FALSE.)
*SET ( SHORTB = .FALSE.)
*SET ( STATS  = .FALSE.)
*IF(CSTAR1)
*SET(DECLAREC='CHARACTER*1')
*ELSE
*SET(DECLAREC='INTEGER    ')
*ENDIF
*COMMENT
 
    DEFINE COMMON BLOCKS
 
*ENDCOM
*SET(GLCOM)
C
C         GLOBAL CONSTANTS
C
      $(DECLAREC)         CA,      CBLANK,  CC,      CI,      CLEFT,
     A                    CMINUS,  CPLUS,   CPOINT,  CQUOTE,  CRIGHT,
     B                    CZ,      C0,      C9
      COMMON  / GLCOMC /  CA,      CBLANK,  CC,      CI,      CLEFT,
     A                    CMINUS,  CPLUS,   CPOINT,  CQUOTE,  CRIGHT,
     B                    CZ,      C0,      C9
*ENDSET
*SET(IOCOM)
C
C         INPUT / OUTPUT CONTROL INTERFACE
C
      $(DECLAREC)         CBUFFR($ICBDIM)
      LOGICAL             LBREAK,  LFORT,   LISTI,   LISTO
      COMMON  / IOCOMC /  CBUFFR
      COMMON  / IOCOMI /  ICBADD,  ICBEND,  ICBEOL,  ICBSUB,  ICB0,
     A                    ICB1,    ICB2,    ICB3,    ICBDIM,  ICPLI,
     B                    ICPLO,   ILCTR,   ILNMBR,  ILPP,    IPAGE,
     A                    IUNITE,  IUNITI,  IUNITL,  IUNITO
      COMMON  / IOCOML /  LBREAK,  LFORT,   LISTI,   LISTO
*ENDSET
*SET(MMCOM)
C
C         MEMORY MANAGER INTERFACE
C
      $(DECLAREC)         CSTORE($ICSDIM)
      INTEGER             IHASH($IHADIM),       ISTORE($ISTDIM)
      COMMON  / MMCOMC /  CSTORE
      COMMON  / MMCOMH /  IHASH
      COMMON  / MMCOMS /  ISTORE
      COMMON  / MMCOMI /  ICSDIM,  ICSP1,   ICSP2,   IHADIM,
     A                    ISFREE,  ISTDIM,  IS2HDC,  IS2HDS
*ENDSET
*SET(MPCOM)
C
C         MACRO PROCESSOR INTERFACE
C
      $(DECLAREC)         CDIV,    CEOL,     CEOR,    CONC,    CSUB,
     A                    CTOP
      LOGICAL             LEMPTY,  LSUB
      COMMON  / MPCOMC /  CDIV,    CEOL,    CEOR,    CONC,    CSUB,
     A                    CTOP
      COMMON  / MPCOML /  LEMPTY,  LSUB
*ENDSET
*SET(TPCOM)
C
C         TEMPLATE PROCESSOR INTERFACE
C
      $(DECLAREC)         CDIR,    CSTAR
      INTEGER             ICBP1(4),         ICBP2(4)
      LOGICAL             LCOL1,   LDIRL,   LEND,    LINITM,  L1TRIP
      COMMON  / TPCOMC /  CDIR,    CSTAR
      COMMON  / TPCOMI /  ICBP1,   ITOPDO,  IARGS,   ICBP2,   INESTD,
     B                    INESTF
      COMMON  / TPCOML /  LCOL1,   LDIRL,   LEND,    LINITM,  L1TRIP
*ENDSET
*COMMENT
 
    IF LIBRARY = .TRUE., A USER SUPPLIED MAIN PROGRAM WILL SERVE
    AS THE CALLING PROGRAM FOR THE TEMPLATE PROCESSOR.  NO MAIN
    PROGRAM IS NECESSARY.
 
*ENDCOM
*IF(LIBRARY = .FALSE.)
*IF(CDC)
*IF(SHORTB)
      PROGRAM  GO  (FILES=102B,  INPUT=102B,  LIST=102B,  OUTPUT=102B,
     A              TAPE4=FILES, TAPE5=INPUT, TAPE6=LIST, TAPE7=OUTPUT)
*ELSE
      PROGRAM  GO  (FILES=102B,  INPUT,       LIST,       OUTPUT,
     A              TAPE4=FILES, TAPE5=INPUT, TAPE6=LIST, TAPE7=OUTPUT)
*ENDIF
*ELSE
C     PROGRAM  GO
*ENDIF
C
C----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     SYSTEM/USER INTERFACE
C
C     PURPOSE
C     -------
C     THIS IS A SAMPLE MAIN PROGRAM TO CALL THE
C     DRIVING ROUTINE OF THE MACRO PROCESSOR.
C
C----------------------------------------------------------------------
*INCLUDE(GLCOM)
*INCLUDE(IOCOM)
*INCLUDE(MMCOM)
*INCLUDE(MPCOM)
*INCLUDE(TPCOM)
*IF(UNIX)
C
C   SET DIMENSIONS FOR ARRAYS
C
      ICBDIM = $ICBDIM
      ICSDIM = $ICSDIM
      IHADIM = $IHADIM
      ISTDIM = $ISTDIM
C
C   INITIALIZE TEMPLATE PROCESSOR
C
      CALL TPMMIN
C
C   CALL DRIVER
C   USING UNIX STANDARD ERROR, INPUT, AND OUTPUT UNITS
C
      CALL  TPDRV  (0, 5, 0, 6)
C
      STOP
*ELSE
*IF(CDC)
C
C         LOCAL VARIABLES AND PARAMETERS
C
      INTEGER             IFNAME(7)
C
C   SET DIMENSIONS FOR ARRAYS
C
      ICBDIM = $ICBDIM
      ICSDIM = $ICSDIM
      IHADIM = $IHADIM
      ISTDIM = $ISTDIM
C
C   INITIALIZE TEMPLATE PROCESSOR
C
      CALL TPMMIN
*IF(STATS)
      TRACE  SUBPROGRAM  CALLS
      TRACE  SUBPROGRAM  TIME
C
*ENDIF
*IF(DEBUG)
      TRACE  DO  LOOPING
      TRACE  STATEMENT  NUMBERS
      TRACE  SUBSCRIPTS
      TRACE  TRANSFERS
C
*ENDIF
      IFNNEW  =  5LINPUT
C
      DO  30  I=2,11
          READ (4, 1010)  (IFNAME(IFN), IFN=1,7)
          IF  (EOF(4) .GT. 0.0)  GO  TO  999
          IFNOLD  =  IFNNEW
          IFNNEW  =  0
          DO  10  IFN=1,7
              IF  (IFNAME(IFN) .EQ. 55B)  GO  TO  20
              IFNNEW  =  IFNNEW .OR. SHIFT(IFNAME(IFN), 60-6*IFN)
   10     CONTINUE
   20     CONTINUE
          IF  (IFNOLD .NE. IFNNEW)  CALL  RENAMEF  (IFNOLD, IFNNEW)
C
C   CALL DRIVER
C
          CALL  TPDRV  (6, 5, 6, 7)
   30 CONTINUE
C
  999 CONTINUE
      STOP
 1010 FORMAT(7R1)
*ENDIF
*ENDIF
      END
*ENDIF
      SUBROUTINE  TPDRV  (IUE0, IUI0, IUL0, IUO0)
C
C-----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     TEMPLATE PROCESSOR
C
C     PURPOSE
C     -------
C     THIS IS THE DRIVING ROUTINE OF THE TEMPLATE PROCESSOR.
C     IT CALLS ROUTINES TO READ, EVALUATE, AND WRITE LINES
C     UNTIL AN END DIRECTIVE IS ENCOUNTERED
C
C     PARAMETERS
C     ----------
C     IUE0    -I-  UNIT NUMBER FOR THE ERROR FILE
C     IUI0    -I-  UNIT NUMBER FOR THE INPUT FILE
C     IUL0    -I-  UNIT NUMBER FOR THE LISTING FILE
C     IUO0    -I-  UNIT NUMBER FOR THE OUTPUT FILE
C
C     COMMON VARIABLES AND DATA STRUCTURES
C     ------------------------------------
C     THE COMMENTS BELOW GIVE A BRIEF DESCRIPTION OF THE COMMON
C     VARIABLES USED BY THE ROUTINES OF THE TEMPLATE PROCESSOR.
C     A MORE DETAILED LOOK AT THE MAIN DATA STRUCTURES IS ALSO
C     INCLUDED.
C
C         GLOBAL CONSTANTS
C
C     COMMON  / GLCOMC /
C         CA       -    'A'           CPOINT   -    '.'
C         CBLANK   -    ' '           CQUOTE   -    '''
C         CC       -    'C'           CRIGHT   -    '('
C         CI       -    'I'           CZ       -    'Z'
C         CLEFT    -    '('           C0       -    '0'
C         CMINUS   -    '-'           C9       -    '9'
C         CPLUS    -    '+'
C
C         INPUT / OUTPUT CONTROL INTERFACE
C
C     COMMON  / IOCOMC /
C         CBUFFR   -    I/O BUFFER
C     COMMON  / IOCOMI /
C         ICBADD   -    NUMBER OF SPACES TO SKIP BEFORE THE CONTINUATION
C                       OF A BROKEN LINE
C         ICBEND   -    BUFFER POSITION OF END OF CURRENT LOGICAL LINE
C                       (LOGICAL LINE MAY INCLUDE SEVERAL ACTUAL LINES)
C         ICBEOL   -    BUFFER POSITION OF CURRENT EOL.
C         ICBSUB   -    BUFFER POSITION OF CURRENT SUB. PREF. CHARACTER
C         ICB0     -    BUFFER POSITION OF START OF CURRENT LINE
C         ICB1     -    BUFFER POSITION WHERE CURRENT PROCESSING BEGINS
C         ICB2     -    BUFFER POSITION WHERE CURRENT PROCESSING ENDS
C         ICB3     -    BUFFER POSITION OF END OF CURRENT LINE
C         ICBDIM   -    DIMENSION OF CBUFFR
C         ICPLI    -    INPUT LINE LENGTH
C         ICPLO    -    OUPUT LINE LENGTH
C         ILCTR    -    LINE NUMBER ON CURRENT LISTING PAGE
C         ILNMBR   -    LINE NUMBER FOR LISTING (OVER ALL PAGES)
C         ILPP     -    MAX NUMBER OF LINES PER LISTING PAGE
C         IPAGE    -    PAGE NUMBER ON LISTING
C         IUNITE   -    ERROR OUTPUT UNIT
C         IUNITI   -    INPUT UNIT
C         IUNITL   -    LISTING OUTPUT UNIT
C         IUNITO   -    STANDARD OUTPUT UNIT
C     COMMON  / IOCOML /
C         LBREAK   -    BREAK LONG LINES AT NICE PLACE IF TRUE
C         LFORT    -    USE FORTRAN CONTINUATION CHAR. IF TRUE
C         LISTI    -    LIST INPUT IF TRUE
C         LISTO    -    LIST OUTPUT IF TRUE
C
C         MEMORY MANAGER INTERFACE
C
C     COMMON  / MMCOMC /
C         CSTORE   -    CHARACTER STORAGE
C     COMMON  / MMCOMH /
C         IHASH    -    HASH TABLE (IHASH(I) IS AN INDEX INTO ISTORE)
C     COMMON  / MMCOMS /
C         ISTORE   -    INTEGER STORAGE; HOLDS THE POINTERS WHICH
C                       IMPLEMENT THE SYMBOL TABLE AND THE STACK
C     COMMON  / MMCOMI /
C         ICSDIM   -    DIMENSION OF ICSDIM
C         ICSP1    -    PTR. TO TOP CHARACTER IN SUBSTITUTION STACK
C         ICSP2    -    PTR. TO LAST CHAR. IN FIRST STRING ON STACK
C         IHADIM   -    DIMENSION OF IHASH
C         ISFREE   -    PTR. TO HEAD OF ISTORE FREELIST
C         ISTDIM   -    DIMENSION OF ISTORE
C         IS2HDC   -    PTR. TO HEAD OF FREE CHARACTER STORAGE BLOCKS
C                       (ACTUALLY AN INDEX INTO ISTORE)
C         IS2HDS   -    PTR. TO TOP OF STACK
C                       (ACTUALLY AN INDEX INTO ISTORE)
C
C         MACRO PROCESSOR INTERFACE
C
C     COMMON  / MPCOMC /
C         CDIV     -    '/'
C         CEOL     -    '-'
C         CEOR     -    '/'
C         CONC     -    '+'
C         CSUB     -    DOLLAR SIGN
C         CTOP     -    TOP CHAR. IN STACK
C     COMMON  / MPCOML /
C         LEMPTY   -    TRUE IF SUBSTITUTION STACK EMPTY
C         LSUB     -    TRUE IF SUBSTITUTIONS ARE TO BE PERFORMED
C
C         TEMPLATE PROCESSOR INTERFACE
C
C     COMMON  / TPCOMC /
C         CDIR     -    '*'
C         CSTAR    -    '*'
C     COMMON  / TPCOMI /
C         ICBP1    -    ICBP1(I) IS BUFF. POSITION OF START OF
C                       ITH ARGUMENT
C         ITOPDO   -    PTR. TO 'TOP' (INNERMOST) DO LOOP ENTRY
C                       IN ISTORE
C         IARGS    -    NUMBER OF ARGUMENTS IN A DIRECTIVE
C         ICBP2    -    ICBP2(I) IS BUFF. POSITION OF END OF
C                       ITH ARGUMENT
C         INESTD   -    DO LOOP NESTING DEPTH
C         INESTF   -    IF-ELSE-ENDIF NESTING DEPTH
C     COMMON  / TPCOML /
C         LCOL1    -    TRUE IF DIRECTIVES MUST BEGIN IN COL 1
C         LDIRL    -    TRUE IF A DIRECTIVE HAS BEEN FOUND
C         LEND     -    TRUE IF AN END DIRECTIVE HAS BEEN FOUND
C         LINITM   -    TRUE IF MMINIT HAS BEEN CALLED
C         L1TRIP   -    TRUE IF ONE TRIP DO-LOOPS SHOULD BE ASSUMED
C
C
C     DATA STRUCTURES
C     ---------------
C
C     I/O BUFFER
C       THE ARRAY CBUFFR HOLDS THE I/O BUFFER.  INPUT LINES ARE READ
C       IN, MACRO SUBSTITUTIONS PERFORMED, AND LISTING  AND OUTPUT
C       (WHEN APPROPRIATE) ARE DONE FROM THE I/O BUFFER.
C
C     INTEGER STORAGE
C       THE ARRAY ISTORE IS USED TO HOLD THE POINTERS WHICH IMPLEMENT
C       THE SYMBOL TABLE AND  THE SUBSTITUTION STACK. IT IS USED IN
C       BLOCKS OF 3 ELEMENTS AT A TIME.  THE VARIABLE ISFREE POINTS
C       TO THE HEAD OF A LINKED LIST OF FREE ISTORE BLOCKS. INITIALLY
C       ALL BLOCKS ARE FREE (THE 3RD ELEMENT IN A BLOCK POINTS TO THE
C       NEXT FREE BLOCK).
C
C     CHARACTER STORAGE
C       THE ARRAY CSTORE PROVIDES A POOL OF CHARACTER STORAGE.  IT
C       IS USED TO RECORD MACRO NAMES AND VALUES, AS WELL AS STRINGS
C       WHICH MUST BE PUSHED ONTO THE SUBSTITUTION STACK.  THE VARIABLE
C       IS2HDC POINTS TO THE HEAD OF A FREELIST OF CHARACTER STORAGE
C       BLOCKS.  THIS FREELIST IS MADE UP OF ISTORE BLOCKS OF THE
C       FOLLOWING FORMAT:
C               ISTORE(I)  = CSTORE INDEX OF FIRST CHAR. IN BLOCK
C               ISTORE(I+1)= CSTORE INDEX OF LAST CHAR. IN BLOCK
C               ISTORE(I+2)= POINTER TO NEXT BLOCK
C
C     SYMBOL TABLE
C       THE SYMBOL TABLE KEEPS TRACK OF MACRO NAMES AND VALUES.  IT
C       IS BUILT OUT OF ISTORE BLOCKS WHICH CONTAIN POINTERS TO
C       OTHER ISTORE BLOCKS OR INDEXES INTO CSTORE.  GIVEN A MACRO
C       NAME, ROUTINE MMHASH COMPUTES ITS HASH INDEX IH.  THEN
C       IHASH(IH) IS THE ISTORE INDEX OF THE SYMBOL TABLE ENTRY FOR
C       THAT NAME.  IF IHASH(IH)=I SAY, THE ISTORE BLOCK AT I HOLDS
C       THE FOLLOWING:
C               ISTORE(I)   = PTR. TO ISTORE BLOCK FOR VARIABLE NAME
C               ISTORE(I+1) = PTR. TO HEAD OF LINKED LIST OF ISTORE
C                             BLOCKS FOR VALUE OF VARIABLE
C               ISTORE(I+2) = PTR. TO TAIL OF THE LINKED LIST FOR THE
C                             VALUE
C
C       AN ISTORE BLOCK FOR THE NAME OF A VARIABLE CONTAINS:
C               ISTORE(J)   = CSTORE INDEX OF FIRST CHAR. IN NAME
C               ISTORE(J+1) = CSTORE INDEX OF LAST CHAR. IN NAME
C               ISTORE(J+2) = 0
C
C       AN ISTORE BLOCK IN THE LINKED LIST WHICH KEEPS TRACK OF
C       THE VALUE OF A VARIABLE LOOKS LIKE:
C               ISTORE(K)   = CSTORE INDEX OF FIRST CHAR. ASSOCIATED
C                             WITH THIS BLOCK
C               ISTORE(K+1) = CSTORE INDEX OF LAST CHAR. ASSOCIATED
C                             WITH THIS BLOCK
C               ISTORE(K+2) = ISTORE INDEX OF NEXT BLOCK IN LIST
C                             (0 IF LAST ONE)
C
C     SUBSTITUTION STACK
C       WHEN A MACRO SUBSTITUTION IS FOUND, IT AND THE REST OF THE
C       CURRENT LINE ARE PUSHED ONTO THE SUBSTITUTION STACK.  THE
C       MACRO NAME IS POPPED OFF AND REPLACED BY ITS VALUE.  CHARACTERS
C       ARE THEN POPPED OFF THE STACK, INTO THE I/O BUFFER, UNTIL
C       THE STACK IS EMPTY OR ANOTHER SUBSTITUTION IS CALLED FOR.
C       IF ANOTHER MACRO SUBSTITUTION IS NEEDED THE SAME PROCESS IS
C       REPEATED--THE MACRO NAME IS REPLACED BY ITS VALUE, AND THE
C       STACK POPPING RESUMES.
C
C       THE STACK IS IMPLEMENTED AS A LINKED LIST OF ISTORE BLOCKS.
C       THE VARIABLE IS2HDS POINTS TO THE TOP BLOCK ON THE STACK.
C       A BLOCK AT INDEX I CONTAINS:
C               ISTORE(I)   = PTR. TO ISTORE BLOCK WHICH POINTS TO A
C                             STRING ON THE STACK
C               ISTORE(I+1) = CSTORE INDEX OF 1ST CHAR. OF
C                             CORRESPONDING STRING
C               ISTORE(I+2) = LINK TO NEXT ISTORE BLOCK ON STACK
C                             (0 IF THERE IS NONE)
C
C       THE FORMAT OF AN ISTORE BLOCK WHICH POINTS TO A STRING ON THE
C       STACK IS LIKE THAT OF ONE WHICH POINTS TO A VARIABLE NAME:
C               ISTORE(J)   = CSTORE INDEX OF FIRST CHAR. IN STRING
C               ISTORE(J+1) = CSTORE INDEX OF LAST CHAR. IN STRING
C               ISTORE(J+2) = 0
C
C
C
C-----------------------------------------------------------------------
*INCLUDE(GLCOM)
*INCLUDE(IOCOM)
*INCLUDE(MMCOM)
*INCLUDE(MPCOM)
*INCLUDE(TPCOM)
C
      CALL  TPINIT  (IUE0, IUI0, IUL0, IUO0)
C
   10 CONTINUE
          ICBEOL  =  0
          CALL  MPLINE  (.TRUE.)
          CALL  TPEVAL
          IF  (.NOT. LDIRL)  CALL  IOWRIT
      IF  (.NOT. LEND)  GO  TO  10
C
      RETURN
      END
      SUBROUTINE  IOERRM  (LFATAL, CFMT)
C
C----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     INPUT/OUTPUT
C
C     PURPOSE
C     -------
C     TO PRINT OUT THE OFFENDING LINE AND AN ERROR MESSAGE BENEATH IT.
C     IF THE ERROR IS FATAL, PROCESSOR EXECUTION IS TERMINATED.
C
C     PARAMETERS
C     ----------
C     LFATAL  -I-  TRUE FOR FATAL ERRORS
C     CFMT    -I-  FORMAT FOR ERROR MESSAGE
C
C----------------------------------------------------------------------
*INCLUDE(IOCOM)
C
C         LOCAL VARIABLES AND PARAMETERS
C
      $(DECLAREC)         CFMT(1)
      LOGICAL             LFATAL
C
*IF(LIBRARY)
      IF  (IUNITE .EQ. IUNITL)  CALL  IOPAGE  (3)
      IF  (ICB0 .GT. ICB2)  GO  TO 10
      WRITE  (IUNITE, 1010)  (CBUFFR(I), I=ICB0,ICB2)
   10 WRITE  (IUNITE, 1020)
 1010 FORMAT(11H +++++++   , 117A1)
 1020 FORMAT(49H +++++++   LIBRARY TEMPLATE PROCESSOR FAILS HERE )
*ELSE
      IF  (IUNITE .EQ. IUNITL)  CALL  IOPAGE  (2)
      IF  (ICB0 .GT. ICB2)  GO  TO 10
      WRITE  (IUNITE, 1010)  (CBUFFR(I), I=ICB0,ICB2)
 1010 FORMAT(12H ********   , 117A1)
   10 CONTINUE
*ENDIF
      WRITE  (IUNITE, CFMT)
      IF  (LFATAL)  STOP
C
      RETURN
      END
      SUBROUTINE  IOLIST  (LNUMBR)
C
C----------------------------------------------------------------------
C
C     INPUT/OUTPUT
C
C     PURPOSE
C     -------
C     TO LIST THE LINE CURRENTLY IN THE INPUT/OUTPUT BUFFER.
C
C     PARAMETER
C     ---------
C     LNUMBR  -I-  TRUE IF THE LINE SHOULD BE NUMBERED
C
C----------------------------------------------------------------------
*INCLUDE(IOCOM)
C
C         LOCAL VARIABLES AND PARAMETERS
C
      LOGICAL             LNUMBR
C
      CALL  IOPAGE  (1)
      IF  (.NOT. LNUMBR)  GO  TO  20
      ILNMBR  =  ILNMBR + 1
C
      IF  (ICB1 .LE. ICB2)  GO  TO  10
      WRITE  (IUNITL, 1010)  ILNMBR
      GO  TO  999
C
   10 CONTINUE
      WRITE  (IUNITL, 1020)  ILNMBR, (CBUFFR(I), I=ICB1,ICB2)
      GO  TO  999
C
   20 CONTINUE
      IF  (ICB1 .LE. ICB2)  GO  TO  30
      WRITE  (IUNITL, 1030)
      GO  TO  999
C
   30 CONTINUE
      WRITE  (IUNITL, 1040)  (CBUFFR(I), I=ICB1,ICB2)
C
  999 CONTINUE
      RETURN
 1010 FORMAT(1H , I8)
 1020 FORMAT(1H , I8, 3X, 117A1)
 1030 FORMAT(1H )
 1040 FORMAT(1H , 11X, 117A1)
      END
      SUBROUTINE  IOPAGE  (IL)
C
C----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     INPUT/OUTPUT
C
C     PURPOSE
C     -------
C     TO DETERMINE IF THERE IS ROOM TO PRINT THE SPECIFIED NUMBER
C     OF LINES ON THE CURRENT PAGE. IF THERE IS NOT, A NEW PAGE
C     IS BEGUN AND A HEADING IS PRINTED.
C
C     PARAMETERS
C     ----------
C     IL      -I-  NUMBER OF LINES TO BE PRINTED
C
C----------------------------------------------------------------------
*INCLUDE(IOCOM)
C
      ILCTR  =  ILCTR + IL
      IF  (ILCTR .LE. ILPP)  GO  TO  999
      IPAGE  =  IPAGE + 1
      ILCTR  =  3 + IL
*IF(LIBRARY=.FALSE.)
      WRITE (IUNITL,1010) IPAGE
*ENDIF
C
  999 CONTINUE
      RETURN
 1010 FORMAT(1H1, 41HPURDUE  UNIVERSITY  TEMPLATE  PROCESSOR  ,
     A            21H(V2 - 07/31/83)  PAGE, I6 //)
      END
      SUBROUTINE  IORDLN (CLINE, ICL1, ICL2, IUNIT)
C
C----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     INPUT/OUTPUT
C
C     PURPOSE
C     -------
C     TO READ A LINE INTO THE INPUT/OUTPUT BUFFER. THIS
C     MAY BE REPLACED BY A MORE EFFICIENT LOCAL I/O ROUTINE
C
C     PARAMETERS
C     ----------
C     CLINE   -I-  I/O BUFFER
C     ICL1    -I-  INDEX OF THE FIRST CHARACTER TO BE READ
C     ICL2    -I-  INDEX OF THE LAST CHARACTER TO BE READ
C     IUNIT   -I-  INPUT UNIT NUMBER
C
C----------------------------------------------------------------------
C
      $(DECLAREC)         CLINE(ICL2)
C
      READ (IUNIT, 1010) (CLINE(I), I=ICL1,ICL2)
C
      RETURN
 1010 FORMAT(132A1)
      END
      SUBROUTINE  IOREAD
C
C----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     SUBSTITUTION PROCESSING
C
C     PURPOSE
C     -------
C     TO FILL THE BUFFER WITH A LINE, REMOVE THE TRAILING BLANKS,
C     SET THE BUFFER POINTERS, AND APPEND AN END-OF-LINE MARKER.
C
C----------------------------------------------------------------------
*INCLUDE(GLCOM)
*INCLUDE(IOCOM)
*INCLUDE(MMCOM)
*INCLUDE(MPCOM)
C
C         IF THERE IS ENOUGH SPACE IN THE BUFFER
C         READ A LINE FROM THE INPUT FILE
C
      ICB1  =  ICB2 + 1
      ICB2  =  ICB2 + ICPLI
      IF  (ICB2+2 .GT. ICBDIM)  GO  TO  30
      CALL  IORDLN (CBUFFR, ICB1, ICB2, IUNITI)
      IF  (LISTI)  CALL  IOLIST  (.TRUE.)
C
C         REMOVE TRAILING BLANKS
C
   10 CONTINUE
          IF  (CBUFFR(ICB2) .NE. CBLANK)  GO  TO  20
          ICB2  =  ICB2 - 1
      IF  (ICB2 .GE. ICB1)  GO  TO  10
C
C         ADD THE END-OF-LINE MARKER
C
   20 CONTINUE
      CBUFFR(ICB2+1)  =  CSUB
      CBUFFR(ICB2+2)  =  CEOL
      ICB3            =  ICB2
      ICBEOL          =  ICB2 + 2
      ICBEND          =  ICBEOL
      GO  TO  999
C
   30 CONTINUE
      CALL  IOERRM  (.TRUE.,
*IF(LIBRARY)
     A 37H(32H +++++++   BUFFER SPACE EXCEEDED))
*ELSE
     A 47H(42H ********   IOREAD - BUFFER SPACE EXCEEDED))
*ENDIF
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE  IOWRIT
C
C----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     SUBSTITUTION PROCESSING
C
C     PURPOSE
C     -------
C     TO WRITE THE LINE CURRENTLY IN THE BUFFER TO THE OUTPUT FILE.
C     IF THE -BREAK- OPTION IS SPECIFIED, AN ATTEMPT WILL BE MADE TO
C     BREAK LONG LINES AT A BLANK, RIGHT PARENTHESIS, COMMA, OR AN
C     ARITHMETIC OPERATOR. IF THE -FORTRAN- OPTION IS SPECIFIED,
C     CONTINUATION LINES WILL BE WRITTEN WITH CONTINUATION CHARACTERS
C     IN COLUMN SIX UNLESS THE LINE IS A COMMENT.
C
C----------------------------------------------------------------------
*INCLUDE(GLCOM)
*INCLUDE(IOCOM)
*INCLUDE(MMCOM)
*INCLUDE(MPCOM)
C
C         LOCAL VARIABLES AND PARAMETERS
C
      $(DECLAREC)         C(7), CBI, COL1
      DATA
     A     ICDIM,  C(1),  C(2),  C(3),  C(4),  C(5),  C(6),  C(7)
     B  /  7,      1H ,   1H),   1H,,   1H/,   1H*,   1H-,   1H+  /
C
      ICB1  =  ICB0
      COL1  =  CBUFFR(ICB1)
      IF  (ICB1 .LE. ICB3)  GO  TO  10
          CBUFFR(ICB1)  =  CBLANK
          ICB2          =  ICB1
          GO  TO  60
C
   10 CONTINUE
          ICB2    =  MIN0(ICB1+ICPLO-1,ICB3)
          IF  (ICB2 .EQ. ICB3)  GO  TO  60
          IF  (.NOT. LBREAK)    GO  TO  40
C
C             FIND A PLACE TO BREAK THE LINE.
C
          DO  30  I=1,10
              CBI  =  CBUFFR(ICB2)
              DO  20  IC=1,ICDIM
                  IF  (C(IC) .EQ. CBI)  GO  TO 30
   20         CONTINUE
              ICB2  =  ICB2 - 1
   30     CONTINUE
C
C             WRITE THE LINE
C
   40     CONTINUE
    CALL  IOWRLN (CBUFFR, ICB1, ICB2, IUNITO)
    IF  (LISTO)  CALL  IOLIST  (.NOT.LISTI)
          ICB1    =  ICB2 + ICBADD
          IF  (.NOT. LFORT)  GO  TO  10
C
C             PAD THE BEGINNING OF THE THE LINE
C             WITH THE STRING BBBBBZBBBB (B=BLANK)
C
          DO  50  ICB=ICB1,ICB2
              CBUFFR(ICB)  =  CBLANK
   50     CONTINUE
          IF  (COL1 .EQ. CC)  CBUFFR(ICB1)    =  CC
          IF  (COL1 .NE. CC)  CBUFFR(ICB1+5)  =  CZ
      GO  TO  10
C
   60 CONTINUE
      CALL  IOWRLN (CBUFFR, ICB1, ICB2, IUNITO)
      IF  (LISTO)  CALL  IOLIST  (.NOT.LISTI)
C
      RETURN
      END
      SUBROUTINE  IOWRLN  (CLINE, ICL1, ICL2, IUNIT)
C
C----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     INPUT/OUTPUT
C
C     PURPOSE
C     -------
C     TO WRITE A LINE FROM THE INPUT/OUTPUT BUFFER.  THIS
C     MAY BE REPLACED BY A MORE EFFICIENT LOCAL I/O ROUTINE
C
C     PARAMETERS
C     ----------
C     CLINE   -I-  I/O BUFFER
C     ICL1    -I-  INDEX OF THE FIRST CHARACTER TO BE WRITTEN
C     ICL2    -I-  INDEX OF THE LAST CHARACTER TO BE WRITTEN
C     IUNIT   -I-  OUTPUT UNIT NUMBER
C
C----------------------------------------------------------------------
      $(DECLAREC)         CLINE(ICL2)
C
      WRITE (IUNIT, 1010) (CLINE(I), I=ICL1,ICL2)
C
      RETURN
 1010 FORMAT(132A1)
      END
      SUBROUTINE  MMAPPV  (CNAME, ICN1, ICN2, CVALUE, ICV1, ICV2)
C
C----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     MEMORY MANAGER
C
C     PURPOSE
C     -------
C     TO APPEND A STRING TO A VARIABLE
C
C     PARAMETERS
C     ----------
C     CNAME    -I-  ARRAY CONTAINING THE NAME OF THE VARIABLE
C     ICN1     -I-  INDEX OF THE FIRST CHARACTER IN THE NAME
C     ICN2     -I-  INDEX OF THE LAST CHARACTER IN THE NAME
C     CVALUE   -I-  ARRAY CONTAINING THE STRING TO BE APPENDED
C     ICV1     -I-  INDEX OF THE FIRST CHARACTER IN THE STRING
C     ICV2     -I-  INDEX OF THE LAST CHARACTER IN THE STRING
C
C----------------------------------------------------------------------
*INCLUDE(GLCOM)
*INCLUDE(IOCOM)
*INCLUDE(MMCOM)
C
C         LOCAL VARIABLES AND PARAMETERS
C
      $(DECLAREC)         CNAME(ICN2), CVALUE(ICV2)
      LOGICAL             LFOUND
C
C         HASH THE VARIABLE NAME TO SEE IF IT EXISTS.
C         IF IT DOES NOT, CREATE IT AND RETURN.
C
      CALL  MMHASH  (CNAME, ICN1, ICN2, IH, LFOUND)
      IF  (LFOUND)  GO  TO  10
          CALL  MMNEWI  (IS1)
          IHASH(IH)  =  IS1
          CALL  MMPUT1  (CNAME,  ICN1, ICN2, ISTORE(IS1), I)
          CALL  MMPUT1  (CVALUE, ICV1, ICV2, ISTORE(IS1+1),
     A                                       ISTORE(IS1+2))
          GO  TO  999
C
C         THE VARIABLE ALREADY EXISTS. APPEND THE VALUE.
C
   10 CONTINUE
      IS1  =  IHASH(IH)
      IS2  =  ISTORE(IS1+2)
      CALL  MMPUT1  (CVALUE, ICV1, ICV2, ISTORE(IS2+2), ISTORE(IS1+2))
C
  999 CONTINUE
      RETURN
      END
 
      SUBROUTINE  MMDELV  (CNAME, ICN1, ICN2, LFOUND)
C
C----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     MEMORY MANAGER
C
C     PURPOSE
C     -------
C     TO DELETE A VARIABLE
C
C     PARAMETERS
C     ----------
C     CNAME   -I-  ARRAY CONTAINING THE NAME OF THE VARIABLE
C     ICN1    -I-  INDEX OF THE FIRST CHARACTER IN THE NAME
C     ICN2    -I-  INDEX OF THE LAST CHARACTER IN THE NAME
C     LFOUND  -O-  TRUE IF THE VARIABLE EXISTED
C
C----------------------------------------------------------------------
*INCLUDE(GLCOM)
*INCLUDE(IOCOM)
*INCLUDE(MMCOM)
C
C         LOCAL VARIABLES AND PARAMETERS
C
      $(DECLAREC)         CNAME(ICN2)
      LOGICAL             LFOUND
C
C         IF THE VARIABLE EXISTS, DELETE IT BY RETURNING THE SPACE
C         TAKEN UP BY IT-S NAME AND VALUE, RETURNING THE SPACE POINTER,
C         AND ZEROING OUT THE HASH TABLE ENTRY.
C
      CALL  MMHASH  (CNAME, ICN1, ICN2, IH, LFOUND)
      IF  (.NOT. LFOUND)  GO  TO  999
      IS1        =  IHASH(IH)
      CALL  MMDEL1  (ISTORE(IS1))
      CALL  MMDEL1  (ISTORE(IS1+1))
      CALL  MMRETI  (IS1)
      IHASH(IH)  =  0
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE  MMDEL1  (IS2)
C
C----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     MEMORY MANAGER
C
C     PURPOSE
C     -------
C     TO RETURN BLOCKS OF CHARACTER STORAGE TO THE FREE SPACE POOL
C
C     PARAMETERS
C     ----------
C     IS2     -I-  POINTER TO THE FIRST LINK IN A LIST
C                  OF CHARACTER STORAGE BLOCKS
C
C----------------------------------------------------------------------
*INCLUDE(GLCOM)
*INCLUDE(IOCOM)
*INCLUDE(MMCOM)
C
      IS  =  IS2
      IF  (IS .EQ. 0)  GO  TO  999
C
C         LOOP THROUGH EVERY LINK TO FIND THE TAIL
C
   10 CONTINUE
          IF  (ISTORE(IS+2) .EQ. 0)  GO  TO  20
          IS  =  ISTORE(IS+2)
      GO  TO  10
C
C         ATTACH THE LIST TO THE FREE SPACE POOL AND
C         RESET THE FREE SPACE HEAD POINTER
C
   20 CONTINUE
      ISTORE(IS+2)  =  IS2HDC
      IS2HDC        =  IS2
C
C
  999 CONTINUE
      RETURN
      END
*IF(NOPACK)
*ELSE
      SUBROUTINE  MMGETC  (CSTORI, ICS)
C
C----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     MEMORY MANAGER
C
C     PURPOSE
C     -------
C     TO GET A CHARACTER FROM THE CHARACTER STORAGE ARRAY.
C     IT SHOULD BE USED TO IMPLEMENT MACHINE DEPENDENT PACKED
C     STORAGE IF THE -CHARACTER*1- DATA TYPE IS NOT AVAILABLE
C     AND THE PROCESSOR REQUIRES AN EXCESSIVE AMOUNT OF MEMORY.
C
C     PARAMETERS
C     ----------
C     CSTORI  -O-  CHARACTER FETCHED FROM STORAGE
C     ICS     -I-  INDEX OF THE CHARACTER TO BE FETCHED
C
C----------------------------------------------------------------------
*INCLUDE(GLCOM)
*INCLUDE(IOCOM)
*INCLUDE(MMCOM)
C
C         LOCAL VARIABLES AND PARAMETERS
C
      $(DECLAREC)         CSTORI
C
      CSTORI  =  CSTORE(ICS)
C
      RETURN
      END
*ENDIF
      SUBROUTINE  MMGETV  (CNAME,  ICN1, ICN2,
     A                     CVALUE, ICV1, ICV2, ICVDIM, LFOUND)
C
C----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     MEMORY MANAGER
C
C     PURPOSE
C     -------
C     TO GET THE VALUE OF THE NAMED VARIABLE FROM THE STORAGE
C     POOL AND COPY IT INTO THE SPECIFIED ARRAY.
C
C     PARAMETERS
C     ----------
C     CNAME   -I-  ARRAY CONTAINING THE NAME OF THE VARIABLE
C     ICN1    -I-  INDEX OF THE FIRST CHARACTER IN THE NAME
C     ICN2     -I-  INDEX OF THE LAST CHARACTER IN THE NAME
C     CVALUE   -O-  ARRAY TO CONTAIN THE VALUE OF THE VARIABLE
C     ICV1     -O-  INDEX OF THE FIRST CHARACTER IN THE VALUE
C     ICV2     -O-  INDEX OF THE LAST CHARACTER IN THE VALUE
C     ICVDIM   -I-  LENGTH OF ARRAY CVALUE
C     LFOUND   -O-  TRUE IF THE VARIABLE EXISTS
C
C----------------------------------------------------------------------
*INCLUDE(GLCOM)
*INCLUDE(IOCOM)
*INCLUDE(MMCOM)
C
C         LOCAL VARIABLES AND PARAMETERS
C
      $(DECLAREC)         CNAME(ICN2), CVALUE(ICVDIM)
      LOGICAL             LFOUND
C
C         IF THE VARIABLE EXISTS, COPY ITS VALUE
C
      ICV2  =  0
      CALL  MMHASH  (CNAME, ICN1, ICN2, IH, LFOUND)
      IF  (.NOT. LFOUND)  GO  TO  999
      IS1   =  IHASH(IH)
      IS2H  =  ISTORE(IS1+1)
      CALL  MMGET1  (CVALUE, ICV1, ICV2, ICVDIM, IS2H)
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE  MMGET1  (CVALUE, ICV1, ICV2, ICVDIM, IS2H)
C
C----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     MEMORY MANAGER
C
C     PURPOSE
C     -------
C     TO COPY THE STRING SPECIFIED BY THE POINTER IS2H
C     AND COPY IT INTO A SPECIFIED ARRAY.
C
C     PARAMETERS
C     ----------
C     CVALUE  -O-  ARRAY TO CONTAIN THE VALUE OF THE VARIABLE
C     ICV1    -O-  INDEX OF THE FIRST CHARACTER IN THE VALUE
C     ICV2    -O-  INDEX OF THE LAST CHARACTER IN THE VALUE
C     ICVDIM  -I-  LENGTH OF ARRAY CVALUE
C     IS2H    -I-  HEAD POINTER TO THE LINKED LIST OF
C                  BLOCKS CONTAINING THE STRING VALUE
C
C----------------------------------------------------------------------
*INCLUDE(GLCOM)
*INCLUDE(IOCOM)
*INCLUDE(MMCOM)
C
C         LOCAL VARIABLES AND PARAMETERS
C
      $(DECLAREC)         CVALUE(ICVDIM)
C
      IS2   =  IS2H
      ICV2  =  ICV1 - 1
C
C         LOOP THROUGH EACH BLOCK IN WHICH THE STRING IS STORED
C
   10 CONTINUE
          IF  (IS2 .EQ. 0)  GO  TO  999
          ICS1  =  ISTORE(IS2)
          ICS2  =  ISTORE(IS2+1)
          IS2   =  ISTORE(IS2+2)
          IF  (ICV2+ICS2-ICS1 .GE. ICVDIM)  GO  TO  30
C
C             LOOP OVER EACH CHARACTER IN THIS BLOCK
C
          DO  20  ICS=ICS1,ICS2
              ICV2  =  ICV2 + 1
*IF(NOPACK)
              CVALUE(ICV2)  =  CSTORE(ICS)
*ELSE
              CALL  MMGETC  (CVALUE(ICV2), ICS)
*ENDIF
   20     CONTINUE
      GO  TO  10
C
   30 CONTINUE
      CALL  IOERRM  (.TRUE.,
*IF(LIBRARY)
     A 45H(40H +++++++   STRING TOO LONG FOR CVALUE(*)))
*ELSE
     A 55H(50H ********   MMGET1 - STRING TOO LONG FOR CVALUE(*)))
*ENDIF
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE  MMHASH  (CNAME, ICN1, ICN2, IH, LFOUND)
C
C----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     MEMORY MANAGER
C
C     PURPOSE
C     -------
C     TO HASH A NAME AND RETURN IT-S HASH TABLE INDEX
C
C     PARAMETERS
C     ----------
C     CNAME   -I-  ARRAY CONTAINING THE NAME OF THE VARIABLE
C     ICN1    -I-  INDEX OF THE FIRST CHARACTER IN THE NAME
C     ICN2    -I-  INDEX OF THE LAST CHARACTER IN THE NAME
C     IH      -O-  HASH INDEX INTO ARRAY IHASH
C     LFOUND  -O-  TRUE IF THE VARIABLE IS ALREADY IN THE TABLE
C
C----------------------------------------------------------------------
*INCLUDE(GLCOM)
*INCLUDE(IOCOM)
*INCLUDE(MMCOM)
C
C         LOCAL VARIABLES AND PARAMETERS
C
      $(DECLAREC)         CNAME(ICN2)
      LOGICAL             LERROR, LFOUND
C
C         ENCODE THE NAME INTO AN INTEGER
C
      CALL  UTCVNI  (CNAME, ICN1, ICN2, INAME, LERROR)
      INAME   =  MOD(INAME, IHADIM)
      IADD    =  MAX0(1, INAME)
      LFOUND  =  .FALSE.
C
C         LOOP THROUGH ENTRIES IN THE TABLE UNTIL THE
C         NAME IS FOUND OR AN EMPTY BUCKET IS REACHED
C
      DO  10  I=1,IHADIM
          IH     =  INAME + 1
          IS1    =  IHASH(IH)
          IF  (IS1 .EQ. 0)  GO  TO  999
          CALL  MMTEST  (CNAME, ICN1, ICN2, ISTORE(IS1), LFOUND)
          IF  (LFOUND)  GO  TO  999
          INAME  =  MOD(INAME+IADD, IHADIM)
   10 CONTINUE
C
C         EXIT FROM THE ABOVE LOOP INDICATES THAT THE HASH
C         TABLE IS FULL. TO OBTAIN MORE SPACE THE PROCESSOR
C         MUST BE RECOMPILED WITH A LARGER DIMENSION -IHADIM-
C         FOR ARRAY IHASH. IHADIM SHOULD BE A PRIME NUMBER.
C
      CALL  IOERRM  (.TRUE.,
*IF(LIBRARY)
     A 49H(44H +++++++   HASH TABLE ARRAY IHASH(*) IS FULL))
*ELSE
     A 59H(54H ********   MMHASH - HASH TABLE ARRAY IHASH(*) IS FULL))
*ENDIF
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE  MMINIT
C
C-----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     MEMORY MANAGER
C
C     PURPOSE
C     -------
C     TO INITIALIZE MEMORY MANAGER VARIABLES
C
C-----------------------------------------------------------------------
*INCLUDE(GLCOM)
*INCLUDE(IOCOM)
*INCLUDE(MMCOM)
C
      DO  10  I=1,IHADIM
          IHASH(I)      =  0
   10 CONTINUE
C
      DO  20  I=1,ISTDIM,3
          ISTORE(I)     =  0
          ISTORE(I+1)   =  0
          ISTORE(I+2)   =  I + 3
   20 CONTINUE
C
      ISTORE(ISTDIM)    =  0
      ISFREE            =  1
C
      CALL  MMNEWI  (IS2HDC)
      ISTORE(IS2HDC)    =  1
      ISTORE(IS2HDC+1)  =  ICSDIM
      ISTORE(IS2HDC+2)  =  0
      IS2HDS            =  0
      ICSP1             =  1
      ICSP2             =  0
C
      RETURN
      END
      SUBROUTINE  MMNEWI  (IS)
C
C-----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     MEMORY MANAGER
C
C     PURPOSE
C     -------
C     TO RETURN A POINTER TO AN AVAILABLE BLOCK FROM THE INTEGER
C     STORAGE POOL
C
C     PARAMETERS
C     ----------
C     IS      -O-  INDEX INTO ARRAY ISTORE OF THE FREE BLOCK
C
C-----------------------------------------------------------------------
*INCLUDE(GLCOM)
*INCLUDE(IOCOM)
*INCLUDE(MMCOM)
C
      IF  (ISFREE .EQ. 0)  GO  TO  10
      IS      =  ISFREE
      ISFREE  =  ISTORE(ISFREE+2)
      GO  TO  999
C
   10 CONTINUE
      CALL  IOERRM  (.TRUE.,
*IF(LIBRARY)
     A 47H(42H +++++++   STORAGE ARRAY ISTORE(*) IS FULL))
*ELSE
     A 57H(52H ********   MMNEWI - STORAGE ARRAY ISTORE(*) IS FULL))
*ENDIF
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE  MMPOPC  (CTEST, IPOP, CTOP, LEMPTY)
C
C-----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     MEMORY MANAGER
C
C     PURPOSE
C     -------
C     TO POP CHARACTERS OFF THE SUBSTITUTION STACK
C
C     PARAMETERS
C     ----------
C     CTEST   -I-  CHARACTER WHOSE PURPOSE DEPENDS ON IPOP
C     IPOP    -I-  INDICATES THE OPERATION TO BE PERFORMED
C                  1 - LOOK AT THE TOP CHARACTER
C                  2 - POP ONE CHARACTER OFF THE STACK
C                  3 - POP ONE VARIABLE OFF THE STACK
C                  4 - POP UNTIL TOP .NE. CTEST
C                  5 - POP UNTIL TOP .EQ. CTEST
C                  6 - POP ALL ALPHNUMERICS
C     CTOP    -O-  TOP CHARACTER ON STACK
C     LEMPTY  -I-  TRUE IF STACK IS EMPTY
C
C-----------------------------------------------------------------------
*INCLUDE(GLCOM)
*INCLUDE(IOCOM)
*INCLUDE(MMCOM)
C
C         LOCAL VARIABLES AND PARAMETERS
C
      $(DECLAREC)         CTEST, CTOP
*IF(TESTCH)
      LOGICAL             LEMPTY
*ELSE
      LOGICAL             L, LEMPTY
*ENDIF
C
   10 CONTINUE
      CTOP  =  CBLANK
C
C         CHECK FOR NULL ENTRIES ON STACK
C
      IF  (ICSP1 .GT. ICSP2)  CALL  MMPOP1  (LEMPTY)
      IF  (LEMPTY)  GO  TO  999
      GO  TO  (20, 30, 40, 50, 70, 90), IPOP
C
C         IPOP = 1  -  LOOK AT THE TOP OF THE STACK
C
   20 CONTINUE
*IF(NOPACK)
      CTOP  =  CSTORE(ICSP1)
*ELSE
      CALL   MMGETC  (CTOP, ICSP1)
*ENDIF
      GO  TO  999
C
C         IPOP = 2  -  POP ONE CHARACTER OFF THE STACK
C
   30 CONTINUE
      ICB2              =  ICB2 + 1
      IF  (ICB2 .GT. ICBDIM)  GO  TO  130
*IF(NOPACK)
      CBUFFR(ICB2)      =  CSTORE(ICSP1)
*ELSE
      CALL  MMGETC  (CBUFFR(ICB2), ICSP1)
*ENDIF
      ICSP1             =  ICSP1 + 1
      ISTORE(IS2HDS+1)  =  ICSP1
      IF  (ICSP1 .GT. ICSP2)  CALL  MMPOP1  (LEMPTY)
*IF(NOPACK)
      IF  (.NOT. LEMPTY)   CTOP  =  CSTORE(ICSP1)
*ELSE
      IF  (.NOT. LEMPTY)   CALL  MMGETC  (CTOP, ICSP1)
*ENDIF
      GO  TO  999
C
C         IPOP = 3  -  POP ONE VARIABLE OFF THE STACK
C
   40 CONTINUE
      ICB2              =  ICB2 + 1
      IF  (ICB2 .GT. ICBDIM)  GO  TO  130
*IF(NOPACK)
      CBUFFR(ICB2)      =  CSTORE(ICSP1)
*ELSE
      CALL  MMGETC  (CBUFFR(ICB2), ICSP1)
*ENDIF
      ISTORE(IS2HDS+1)  =  ICSP1 + 1
      CALL  MMPOPV  (LEMPTY)
      CALL  MMPOP1  (LEMPTY)
*IF(NOPACK)
      IF  (.NOT. LEMPTY)    CTOP  =  CSTORE(ICSP1)
*ELSE
      IF  (.NOT. LEMPTY)    CALL  MMGETC  (CTOP, ICSP1)
*ENDIF
      GO  TO  999
C
C         IPOP = 4  -  POP UNTIL TOP CHAR .NE. CTEST
C
   50 CONTINUE
      IF  (ICSP2-ICSP1 .GE. ICBDIM-ICB2)  GO  TO  130
      DO  60  ICS=ICSP1,ICSP2
*IF(NOPACK)
          IF  (CSTORE(ICS) .NE. CTEST)  GO  TO  120
          ICB2          =  ICB2 + 1
          CBUFFR(ICB2)  =  CSTORE(ICS)
*ELSE
          CALL  MMGETC  (CTOP, ICS)
          IF  (CTOP .NE. CTEST)   GO  TO  120
          ICB2          =  ICB2 + 1
          CBUFFR(ICB2)  =  CTOP
*ENDIF
   60 CONTINUE
      GO  TO  110
C
C         IPOP = 5  -  POP UNTIL TOP CHAR .EQ. CTEST
C
   70 CONTINUE
      IF  (ICSP2-ICSP1 .GE. ICBDIM-ICB2)  GO  TO  130
      DO  80  ICS=ICSP1,ICSP2
*IF(NOPACK)
          IF  (CSTORE(ICS) .EQ. CTEST)   GO  TO  120
          ICB2          =  ICB2 + 1
          CBUFFR(ICB2)  =  CSTORE(ICS)
*ELSE
          CALL  MMGETC  (CTOP, ICS)
          IF  (CTOP .EQ. CTEST)   GO  TO  120
          ICB2          =  ICB2 + 1
          CBUFFR(ICB2)  =  CTOP
*ENDIF
   80 CONTINUE
      GO  TO  110
C
C         IPOP = 6  -  POP ALL ALPHANUMERICS OFF THE STACK
C
   90 CONTINUE
      IF  (ICSP2-ICSP1 .GE. ICBDIM-ICB2)  GO  TO  130
      DO  100  ICS=ICSP1,ICSP2
*IF(NOPACK)
*IF(TESTCH)
          IF  (.NOT. (((CA .LE. CSTORE(ICS))
     A         .AND.   (CSTORE(ICS) .LE. CZ))
     B         .OR.   ((C0 .LE. CSTORE(ICS))
     C         .AND.   (CSTORE(ICS) .LE. C9))))  GO  TO  120
*ELSE
          CALL  UTCHKS  (CSTORE(ICS), L)
          IF  (L)                 GO  TO  120
*ENDIF
          ICB2          =  ICB2 + 1
          CBUFFR(ICB2)  =  CSTORE(ICS)
*ELSE
          CALL  MMGETC  (CTOP, ICS)
*IF(TESTCH)
          IF  (.NOT.(((CA .LE. CTOP) .AND. (CTOP .LE. CZ))
     A         .OR.  ((C0 .LE. CTOP) .AND. (CTOP .LE. C9)))  GO  TO  120
*ELSE
          CALL  UTCHKS  (CTOP, L)
          IF  (L)                 GO  TO  120
*ENDIF
          ICB2          =  ICB2 + 1
          CBUFFR(ICB2)  =  CTOP
*ENDIF
  100 CONTINUE
C
C         THE SPECIFIED CONDITION HAS NOT BEEN MET.
C         GET ANOTHER PIECE OF THE STACK AND TRY AGAIN.
C
  110 CONTINUE
      ICSP1             =  ICSP2 + 1
      ISTORE(IS2HDS+1)  =  ICSP1
      GO  TO  10
C
C         THE SPECIFIED CONDITION HAS BEEN MET.
C         SAVE THE STACK POINTER AND RETURN.
C
  120 CONTINUE
      ICSP1             =  ICS
      ISTORE(IS2HDS+1)  =  ICS
*IF(NOPACK)
      CTOP              =  CSTORE(ICS)
*ENDIF
      GO  TO  999
C
C         THE BUFFER SPACE HAS BEEN EXCEEDED
C
  130 CONTINUE
      CALL  IOERRM  (.TRUE.,
*IF(LIBRARY)
     A 42H(37H +++++++   STRING TOO LONG FOR BUFFER))
*ELSE
     A 52H(47H ********   MMPOPC - STRING TOO LONG FOR BUFFER))
*ENDIF
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE  MMPOPV  (LEMPTY)
C
C-----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     MEMORY MANAGER
C
C     PURPOSE
C     -------
C     TO POP A VARIABLE OFF THE SUBSTITUTION STACK
C
C     PARAMETERS
C     ----------
C     LEMPTY  -O-  TRUE IF THE STACK IS EMPTY
C
C-----------------------------------------------------------------------
*INCLUDE(GLCOM)
*INCLUDE(IOCOM)
*INCLUDE(MMCOM)
C
C         LOCAL VARIABLES AND PARAMETERS
C
      LOGICAL             LEMPTY
C
      LEMPTY         =  IS2HDS .EQ. 0
      IF  (LEMPTY)  GO  TO  999
      IS2            =  IS2HDS
      IS2HDS         =  ISTORE(IS2+2)
      ISTORE(IS2+2)  =  0
      LEMPTY         =  IS2HDS .EQ. 0
      IF  (ISTORE(IS2) .GT. 0)  CALL  MMRETI  (IS2)
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE  MMPOP1  (LEMPTY)
C
C-----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     MEMORY MANAGER
C
C     PURPOSE
C     -------
C     TO POP NULL ENTRIES OFF THE SUBSTITUTION STACK
C
C     PARAMETERS
C     ----------
C     LEMPTY  -O-  TRUE IF THE STACK IS EMPTY
C
C-----------------------------------------------------------------------
*INCLUDE(GLCOM)
*INCLUDE(IOCOM)
*INCLUDE(MMCOM)
C
C         LOCAL VARIABLES AND PARAMETERS
C
      LOGICAL             LEMPTY
C
   10 CONTINUE
          LEMPTY            =  IS2HDS .EQ. 0
          IF  (LEMPTY)  GO  TO  999
          IS2               =  IABS(ISTORE(IS2HDS))
          IF  (IS2 .NE. 0)  GO  TO  30
   20     CONTINUE
          CALL  MMPOPV  (LEMPTY)
      GO  TO  10
C
   30 CONTINUE
          ICSP1              =  ISTORE(IS2HDS+1)
          ICSP2              =  ISTORE(IS2+1)
          IF  (ICSP1 .LE. ICSP2)  GO  TO  999
          IS2               =  ISTORE(IS2+2)
          IF  (IS2 .EQ. 0)  GO  TO  20
          ISTORE(IS2HDS)    =  ISIGN(IS2, ISTORE(IS2HDS))
          ISTORE(IS2HDS+1)  =  ISTORE(IS2)
      GO  TO  30
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE  MMPSHV  (CNAME, ICN1, ICN2, IPUSH, LEMPTY, LFOUND)
C
C-----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     MEMORY MANAGER
C
C     PURPOSE
C     -------
C     TO PUSH A VARIABLE ONTO THE SUBSTITUTION STACK
C
C     PARAMETERS
C     ----------
C     CNAME   -I-  THE NAME OF THE VARIABLE TO PUSH ONTO THE STACK
C     ICN1    -I-  INDEX OF THE FIRST CHARACTER IN THE NAME
C     ICN2    -I-  INDEX OF THE LAST CHARACTER IN THE NAME
C     IPUSH   -I-  INDICATES THE OPERATION TO BE PERFORMED
C                  1 - PUSH A VARIABLE ONTO THE STACK
C                  2 - PUSH A POINTER ONTO THE STACK
C                  3 - PUSH THE ACTUAL POINTER ONTO THE STACK
C
C-----------------------------------------------------------------------
*INCLUDE(GLCOM)
*INCLUDE(IOCOM)
*INCLUDE(MMCOM)
C
C         LOCAL VARIABLES AND PARAMETERS
C
      $(DECLAREC)         CNAME(ICN2)
      LOGICAL             LEMPTY, LFOUND
C
      CALL  MMHASH  (CNAME, ICN1, ICN2, IH, LFOUND)
      IF  (.NOT. LFOUND)  GO  TO  999
      IS1              =  IHASH(IH)
      IS2              =  ISTORE(IS1+1)
      IF  (IS2 .EQ. 0)    GO  TO  999
      IF  (IPUSH .EQ. 1)  GO  TO  10
      IF  (IPUSH .EQ. 2)  GO  TO  20
      GO  TO  30
C
C         PUSH A VARIABLE ONTO THE STACK; NEW ENTRY WILL POINT TO
C         VALUE OF THE VARIABLE
C
   10 CONTINUE
      CALL  MMNEWI  (ITEMP)
      ISTORE(ITEMP)    =  IS2
      ISTORE(ITEMP+1)  =  ISTORE(IS2)
      ISTORE(ITEMP+2)  =  IS2HDS
      IS2HDS           =  ITEMP
      GO  TO  40
C
C         PUSH A POINTER ONTO THE STACK
C
   20 CONTINUE
      CALL  MMNEWI  (ITEMP)
      ISTORE(ITEMP)    =  ISTORE(IS2)
      ISTORE(ITEMP+1)  =  ISTORE(IS2+1)
      ISTORE(ITEMP+2)  =  IS2HDS
      IS2HDS           =  ITEMP
      GO  TO  40
C
C         PUSH THE ACTUAL POINTER ONTO THE STACK
C
   30 CONTINUE
      ISTORE(IS2)      =  -IABS(ISTORE(IS2))
      ISTORE(IS2+2)    =  IS2HDS
      IS2HDS           =  IS2
C
C         CALL MMPOP1 TO SET THE POINTERS (ICSP1, ICSP2) INTO CSTORE
C
   40 CONTINUE
      CALL  MMPOP1  (LEMPTY)
C
  999 CONTINUE
      RETURN
      END
*IF(NOPACK)
*ELSE
      SUBROUTINE  MMPUTC  (CSTORI, ICS)
C
C-----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     MEMORY MANAGER
C
C     PURPOSE
C     -------
C     TO PUT A CHARACTER INTO CSTORE AT THE INDICATED POSITION.
C     THIS ROUTINE SHOULD BE REPLACED WITH ONE WHICH PACKS CHARACTERS
C     INTO CSTORE
C
C     PARAMETERS
C     ----------
C     CSTORI  -I-  THE CHARACTER TO STORE
C     ICS     -I-  THE INDEX INTO CSTORE
C
C-----------------------------------------------------------------------
*INCLUDE(GLCOM)
*INCLUDE(IOCOM)
*INCLUDE(MMCOM)
C
C         LOCAL VARIABLES AND PARAMETERS
C
      $(DECLAREC)         CSTORI
C
      CSTORE(ICS)  =  CSTORI
C
      RETURN
      END
*ENDIF
      SUBROUTINE  MMPUTP  (CNAME, ICN1, ICN2, CPTR, ICP1, ICP2, LFOUND)
C
C-----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     MEMORY MANAGER
C
C     PURPOSE
C     -------
C     TO PUT A POINTER TO A VARIABLE IN THE SYMBOL TABLE
C
C     PARAMETERS
C     ----------
C     CNAME   -I-  NAME OF THE VARIABLE
C     ICN1    -I-  INDEX OF THE FIRST CHARACTER IN THE NAME
C     ICN2    -I-  INDEX OF THE LAST CHARACTER IN THE NAME
C     CPTR    -I-  NAME OF THE POINTER
C     ICP1    -I-  INDEX OF THE FIRST CHARACTER IN THE POINTER NAME
C     ICP2    -I-  INDEX OF THE LAST CHARACTER IN THE POINTER NAME
C     LFOUND  -O-  TRUE IF THE VARIABLE WAS FOUND IN THE TABLE
C
C-----------------------------------------------------------------------
*INCLUDE(GLCOM)
*INCLUDE(IOCOM)
*INCLUDE(MMCOM)
C
C         LOCAL VARIABLES AND PARAMETERS
C
      $(DECLAREC)         CNAME(ICN2), CPTR(ICP2)
      LOGICAL             L, LFOUND
C
      CALL  MMHASH  (CNAME, ICN1, ICN2, IH, LFOUND)
      IF  (.NOT. LFOUND)  GO  TO  999
      IS1            =  IHASH(IH)
      IS2CN          =  ISTORE(IS1+1)
      CALL  MMHASH  (CPTR, ICP1, ICP2, IH, L)
      IF  (L)  GO  TO  10
          CALL  MMNEWI  (IS1)
          IHASH(IH)      =  IS1
          CALL  MMPUT1  (CPTR, ICP1, ICP2, ISTORE(IS1), I)
          CALL  MMNEWI  (IS2)
          ISTORE(IS1+1)  =  IS2
          ISTORE(IS1+2)  =  0
          GO  TO  20
C
   10 CONTINUE
      IS1            =  IHASH(IH)
      IS2            =  ISTORE(IS1+1)
C
   20 CONTINUE
      IF  (IS2CN .NE. 0)  GO  TO  30
      ISTORE(IS2)    =  0
      ISTORE(IS2+1)  =  0
      ISTORE(IS2+2)  =  0
      GO  TO  999
C
   30 CONTINUE
      ISTORE(IS2)    =  IS2CN
      ISTORE(IS2+1)  =  ISTORE(IS2CN)
      ISTORE(IS2+2)  =  0
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE  MMPUTV  (CNAME, ICN1, ICN2, CVALUE, ICV1, ICV2)
C
C-----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     MEMORY MANAGER
C
C     PURPOSE
C     -------
C     TO PUT A VARIABLE INTO THE SYMBOL TABLE
C
C     PARAMETERS
C     ----------
C     CNAME   -I-  NAME OF THE VARIABLE
C     ICN1    -I-  INDEX OF THE FIRST CHARACTER IN THE NAME
C     ICN2    -I-  INDEX OF THE LAST CHARACTER IN THE NAME
C     CVALUE  -I-  VALUE OF THE VARIABLE
C     ICV1    -I-  INDEX OF THE FIRST CHARACTER IN THE VALUE
C     ICV2    -I-  INDEX OF THE LAST CHARACTER IN THE VALUE
C
C-----------------------------------------------------------------------
*INCLUDE(GLCOM)
*INCLUDE(IOCOM)
*INCLUDE(MMCOM)
C
C         LOCAL VARIABLES AND PARAMETERS
C
      $(DECLAREC)         CNAME(ICN2), CVALUE(ICV2)
      LOGICAL             LFOUND
C
C         HASH THE NAME TO SEE IF IT IS IN THE TABLE.
C         IF IT IS NOT, STORE A NEW NAME IN THE TABLE.
C
      CALL  MMHASH  (CNAME, ICN1, ICN2, IH, LFOUND)
      IF  (LFOUND)  GO  TO  10
          CALL  MMNEWI  (IS1)
          IHASH(IH)  =  IS1
          CALL  MMPUT1  (CNAME, ICN1, ICN2, ISTORE(IS1), I)
          GO  TO  20
C
C         RETURN THE SPACE ALLOCATED TO THE OLD VALUE
C
   10 CONTINUE
      IS1   =  IHASH(IH)
      CALL  MMDEL1  (ISTORE(IS1+1))
C
C         STORE THE NEW VALUE IN THE TABLE
C
   20 CONTINUE
      CALL  MMPUT1  (CVALUE, ICV1, ICV2, ISTORE(IS1+1), ISTORE(IS1+2))
C
      RETURN
      END
 
      SUBROUTINE  MMPUT1  (CVALUE, ICV1, ICV2, IS2H, IS2T)
C
C-----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     MEMORY MANAGER
C
C     PURPOSE
C     -------
C     TO PUT A STRING VALUE INTO CHARACTER STORAGE
C     AND RETURN POINTERS TO ITS LOCATION
C
C     PARAMETERS
C     ----------
C     CVALUE  -I-  CONTAINS THE CHARACTER STRING
C     ICV1    -I-  INDEX OF THE FIRST CHARACTER IN THE STRING
C     ICV2    -I-  INDEX OF THE LAST CHARACTER IN THE STRING
C     IS2H    -O-  POINTER TO THE FIRST BLOCK CONTAINING THE STRING
C     IS2T    -O-  POINTER TO THE LAST BLOCK CONTAINING THE STRING
C
C     LOCAL VARIABLES
C     ---------------
C     ICV      -   INDEX OF THE CURRENT CHARACTER IN THE STRING
C     IS2      -   POINTER TO CURRENT BLOCK FOR THE STRING
C     ICS      -   INDEX OF CURRENT STORE POSITION IN CSTORE
C     ICS1     -   INDEX OF BEGINNING OF CURRENT CSTORE BLOCK
C     ICS2     -   INDEX OF END OF CURRENT CSTORE BLOCK
C     ICSTST   -   INDEX OF LAST CSTORE POSITION NEEDED
C     ICSMIN   -   INDEX OF LAST CSTORE POSITION NEEDED IN CURRENT BLOCK
C
C-----------------------------------------------------------------------
*INCLUDE(GLCOM)
*INCLUDE(IOCOM)
*INCLUDE(MMCOM)
C
C         LOCAL VARIABLES AND PARAMETERS
C
      $(DECLAREC)         CVALUE(ICV2)
C
      IF  ((ICV1 .GT. 0) .AND. (ICV1 .LE. ICV2))  GO  TO  10
          IS2H  =  0
          IS2T  =  0
          GO  TO  999
C
   10 CONTINUE
      ICV   =  ICV1
      IS2   =  IS2HDC
      IS2H  =  IS2HDC
C
C         LOOP THROUGH THE LINKED LIST OF AVAILABLE MEMORY BLOCKS
C
   20 CONTINUE
          IF  (IS2 .EQ. 0)  GO  TO  60
          IS2T    =  IS2
          ICS1    =  ISTORE(IS2T)
          ICS2    =  ISTORE(IS2T+1)
          IS2     =  ISTORE(IS2T+2)
          ICSTST  =  ICS1 + ICV2 - ICV
          ICSMIN  =  MIN0(ICS2, ICSTST)
C
C             STORE CHARACTERS INTO A PARTICULAR BLOCK
C
          DO  30  ICS=ICS1,ICSMIN
*IF(NOPACK)
              CSTORE(ICS)  =  CVALUE(ICV)
*ELSE
              CALL  MMPUTC  (CVALUE(ICV), ICS)
*ENDIF
              ICV  =  ICV + 1
   30     CONTINUE
      IF  (ICSTST .GT. ICS2)  GO  TO  20
C
C         IF THE LAST BLOCK USED WAS COMPLETELY FILLED, GO TO 40
C
      IF  (ICSTST .NE. ICS2)  GO  TO  40
          IS2HDC  =  IS2
          GO  TO  50
C
C         THE LAST BLOCK OF MEMORY WAS NOT COMPLETELY USED.
C         PUT A NEW BLOCK ON THE AVAILABLE MEMORY STACK
C         CORRESPONDING TO THE REMAINING CHARACTERS.
C
   40 CONTINUE
      CALL  MMNEWI  (IS2HDC)
      ISTORE(IS2HDC)    =  ICSMIN+1
      ISTORE(IS2HDC+1)  =  ICS2
      ISTORE(IS2HDC+2)  =  IS2
C
   50 CONTINUE
      ISTORE(IS2T+1)    =  ICSTST
      ISTORE(IS2T+2)    =  0
      GO  TO  999
C
C         FATAL ERROR - NO MORE CHARACTER STORAGE SPACE
C
   60 CONTINUE
      CALL  IOERRM  (.TRUE.,
*IF(LIBRARY)
     A 44H(39H +++++++   STORAGE ARRAY CSTORE(*) FULL))
*ELSE
     A 54H(49H ********   MMPUT1 - STORAGE ARRAY CSTORE(*) FULL))
*ENDIF
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE  MMRETI  (IS)
C
C-----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     MEMORY MANAGER
C
C     PURPOSE
C     -------
C     TO RETURN AN INTEGER BLOCK TO THE FREE LIST
C
C     PARAMETERS
C     ----------
C     IS      -I-  POINTER TO THE BLOCK TO BE RETURNED
C
C-----------------------------------------------------------------------
*INCLUDE(GLCOM)
*INCLUDE(IOCOM)
*INCLUDE(MMCOM)
C
      IF  (IS .EQ. 0)  GO  TO  999
      IF  ((IS .LT. 0) .OR. (IS .GT. ISTDIM)
     A                 .OR. (MOD(IS,3) .NE. 1))  GO  TO  10
      ISTORE(IS+2)  =  ISFREE
      ISFREE        =  IS
      GO  TO  999
C
   10 CONTINUE
      CALL  IOERRM  (.FALSE.,
*IF(LIBRARY)
     A 49H(44H +++++++   ATTEMPT TO RETURN INVALID POINTER))
*ELSE
     A 59H(54H ********   MMRETI - ATTEMPT TO RETURN INVALID POINTER))
*ENDIF
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE  MMSETP  (CPTR, ICP1, ICP2)
C
C-----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     MEMORY MANAGER
C
C     PURPOSE
C     -------
C     TO SAVE A POINTER TO THE CURRENT TOP OF THE SUBSTITUTION STACK
C
C     PARAMETERS
C     ----------
C     CPTR    -I-  NAME OF THE POINTER
C     ICP1    -I-  INDEX OF THE FIRST CHARACTER IN THE NAME
C     ICP2    -I-  INDEX OF THE LAST CHARACTER IN THE NAME
C
C-----------------------------------------------------------------------
*INCLUDE(GLCOM)
*INCLUDE(IOCOM)
*INCLUDE(MMCOM)
C
C         LOCAL VARIABLES AND PARAMETERS
C
      $(DECLAREC)         CPTR(ICP2)
      LOGICAL             LFOUND
C
      CALL  MMHASH  (CPTR, ICP1, ICP2, IH, LFOUND)
      IF  (.NOT. LFOUND)  GO  TO  10
      IS1            =  IHASH(IH)
      IS2            =  ISTORE(IS1+1)
      GO  TO  20
C
   10 CONTINUE
      CALL  MMNEWI  (IS1)
      IHASH(IH)      =  IS1
      CALL  MMPUT1  (CPTR, ICP1, ICP2, ISTORE(IS1), I)
      CALL  MMNEWI  (IS2)
      ISTORE(IS1+1)  =  IS2
      ISTORE(IS1+2)  =  0
C
   20 CONTINUE
      IF  (IS2HDS .NE. 0)  GO  TO  30
      ISTORE(IS2)    =  0
      ISTORE(IS2+1)  =  0
      ISTORE(IS2+2)  =  0
      GO  TO  999
C
   30 CONTINUE
      ISTORE(IS2)    =  ISTORE(IS2HDS)
      ISTORE(IS2+1)  =  ISTORE(IS2HDS+1)
      ISTORE(IS2+2)  =  0
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE  MMTEST  (CVALUE, ICV1, ICV2, IS2H, LEQUAL)
C
C-----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     MEMORY MANAGER
C
C     PURPOSE
C     -------
C     TO SEE IF A GIVEN STRING IS EQUAL TO ONE IN THE SYMBOL TABLE
C
C     PARAMETERS
C     ----------
C     CVALUE  -I-  CONTAINS THE STRING TO BE TESTED
C     ICV1    -I-  INDEX OF THE FIRST CHARACTER IN THE STRING
C     ICV2    -I-  INDEX OF THE LAST CHARACTER IN THE STRING
C     IS2H    -I-  POINTER TO THE STRING IN THE SYMBOL TABLE
C     LEQUAL  -O-  TRUE IF THE STRINGS ARE EQUAL
C
C-----------------------------------------------------------------------
*INCLUDE(GLCOM)
*INCLUDE(IOCOM)
*INCLUDE(MMCOM)
C
C         LOCAL VARIABLES AND PARAMETERS
C
      $(DECLAREC)         CSTORI, CVALUE(ICV2)
      LOGICAL             LEQUAL
C
      ICV     =  ICV1
      IS2     =  IS2H
      LEQUAL  =  .FALSE.
C
   10 CONTINUE
          IF  (IS2 .EQ. 0)  GO  TO  30
          ICS1  =  ISTORE(IS2)
          ICS2  =  ISTORE(IS2+1)
          IS2   =  ISTORE(IS2+2)
          IF  (ICS2-ICS1 .GT. ICV2-ICV)  GO  TO  999
          DO  20  ICS=ICS1,ICS2
*IF(NOPACK)
              IF  (CSTORE(ICS) .NE. CVALUE(ICV))  GO  TO  999
*ELSE
              CALL  MMGETC  (CSTORI, ICS)
              IF  (CSTORI .NE. CVALUE(ICV))  GO  TO  999
*ENDIF
              ICV  =  ICV + 1
   20     CONTINUE
      GO  TO  10
C
   30 CONTINUE
      LEQUAL  =  ICV .GT. ICV2
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE  MPEOL
C
C-----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     MACRO PROCESSOR
C
C     PURPOSE
C     -------
C     TO REMOVE TRAILING BLANKS AND ADD AN END-OF-LINE MARKER
C     TO THE LINE IN THE INPUT/OUTPUT BUFFER
C
C-----------------------------------------------------------------------
*INCLUDE(GLCOM)
*INCLUDE(IOCOM)
*INCLUDE(MMCOM)
*INCLUDE(MPCOM)
C
C         LOCAL VARIABLES AND PARAMETERS
C
      $(DECLAREC)         C
C
      CALL  MMPOPC  (C, 2, CTOP, LEMPTY)
      ICBEOL  =  ICB2
      ICBEND  =  ICBEOL
      ICB2    =  ICB2 - 2
      ICB3    =  ICB2
      IF  (ICB1 .GT. ICB2)            GO  TO  999
      IF  (CBUFFR(ICB2) .NE. CBLANK)  GO  TO  999
C
C         REMOVE TRAILING BLANKS
C
   10 CONTINUE
          ICB2  =  ICB2 - 1
          IF  (ICB1 .GT. ICB2)        GO  TO  20
      IF  (CBUFFR(ICB2) .EQ. CBLANK)  GO  TO  10
C
C         ADD THE END-OF-LINE MARKER
C
   20 CONTINUE
      CBUFFR(ICB2+1)  =  CSUB
      CBUFFR(ICB2+2)  =  CEOL
      ICB3            =  ICB2
      ICBEOL          =  ICB2 + 2
      ICBEND          =  ICBEOL
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE  MPITEM
C
C-----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     MACRO PROCESSOR
C
C     PURPOSE
C     -------
C     TO PUSH THE NEXT ITEM IN A LIST ONTO THE SUBSTITUTION STACK
C
C-----------------------------------------------------------------------
*INCLUDE(GLCOM)
*INCLUDE(IOCOM)
*INCLUDE(MMCOM)
*INCLUDE(MPCOM)
C
C         LOCAL VARIABLES AND PARAMETERS
C
      LOGICAL             LERROR, LFOUND
C
      CALL  MPPOPN  (ICN1, ICN2, LERROR)
      ICP1  =  ICB2 + 1
      CALL  UTBLDN  (CDIV, CBUFFR, ICN1, ICN2, 1,
     A               CBUFFR, ICP1, ICP2, ICBDIM, LERROR)
      CALL  MMPSHV  (CBUFFR, ICP1, ICP2, 3, LEMPTY, LFOUND)
      IF  (LFOUND)  GO  TO  10
      CALL  MMPUTP  (CBUFFR, ICN1, ICN2, CBUFFR, ICP1, ICP2, LFOUND)
      IF  (.NOT. LFOUND)  GO  TO  20
      CALL  MMPSHV  (CBUFFR, ICP1, ICP2, 3, LEMPTY, LFOUND)
C
   10 CONTINUE
      ICB2  =  ICBSUB - 1
      GO  TO  999
C
   20 CONTINUE
      CALL  IOERRM  (.FALSE.,
*IF(LIBRARY)
     A 36H(31H +++++++   VARIABLE NOT DEFINED))
*ELSE
     A 46H(41H ********   MPITEM - VARIABLE NOT DEFINED))
*ENDIF
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE  MPLABL
C
C-----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     MACRO PROCESSOR
C
C     PURPOSE
C     -------
C     TO COPY THE CURRENT LABEL TO THE BUFFER AND THEN
C     INCREMENT AND SAVE ITS VALUE
C
C-----------------------------------------------------------------------
*INCLUDE(GLCOM)
*INCLUDE(IOCOM)
*INCLUDE(MMCOM)
*INCLUDE(MPCOM)
C
C         LOCAL VARIABLES AND PARAMETERS
C
      $(DECLAREC)         C(5)
      LOGICAL             L
      DATA                ICNDIM, C(1), C(2), C(3), C(4), C(5)
     A                 /  5,      1HL,  1HA,  1HB,  1HE,  1HL  /
C
C         GET CURRENT VALUE OF LABEL, CONVERT TO AN INTEGER AND
C         CHECK IT.  ADD ONE, CONVERT BACK TO CHARACTERS AND PLACE
C         IN CBUFFR
C
      ICV1  =  ICB2 + 5
      CALL  MMGETV  (C, 1, ICNDIM, CBUFFR, ICV1, ICV2, ICBDIM, L)
      IF  (.NOT. L)  GO  TO  40
      CALL  UTCVCI  (CBUFFR, ICV1, ICV2, I, L)
      IF  ((I .LT. 0) .OR. (99999 .LT. I))  GO  TO  40
      I       =  I + 1
      CALL  UTCVIC  (CBUFFR, ICV1, ICV2, ICBDIM, I, L)
      ICV2M4  =  ICV2 - 4
      ICV1M1  =  ICV1 - 1
      IF  (ICV2M4 .GT. ICV1M1)  GO  TO  20
C
      DO  10  I=ICV2M4,ICV1M1
          CBUFFR(I)  =  CBLANK
   10 CONTINUE
C
   20 CONTINUE
      CALL  MMPUTV  (C, 1, ICNDIM, CBUFFR, ICV2M4, ICV2)
      ICB2  =  ICBSUB - 1
      DO  30  I=ICV2M4,ICV2
          ICB2  =  ICB2 + 1
          CBUFFR(ICB2)  =  CBUFFR(I)
   30 CONTINUE
      GO  TO  999
C
C         WARNING - INVALID LABEL VALUE
C
   40 CONTINUE
      CALL  IOERRM  (.FALSE.,
*IF(LIBRARY)
     A 35H(30H +++++++   ILLEGAL LABEL VALUE))
*ELSE
     A 45H(40H ********   MPLABL - ILLEGAL LABEL VALUE))
*ENDIF
C
  999 CONTINUE
      RETURN
      END
 
      SUBROUTINE  MPLINE  (LSUBL)
C
C-----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     MACRO PROCESSOR
C
C     PURPOSE
C     -------
C     TO BUILD THE NEXT LINE IN THE I/O BUFFER
C
C     PARAMETERS
C     ----------
C     LSUBL   -I-  LOCAL SUBSTITUTION FLAG INDICATING WHETHER
C                  OR NOT MACROS ON THIS LINE ARE TO BE EXPANDED
C
C-----------------------------------------------------------------------
*INCLUDE(GLCOM)
*INCLUDE(IOCOM)
*INCLUDE(MMCOM)
*INCLUDE(MPCOM)
C
C         LOCAL VARIABLES AND PARAMETERS
C
      $(DECLAREC)         C(2)
      LOGICAL             LEOL, LFOUND, LSUBL
      DATA                ICNDIM, C(1), C(2)  /  2, 1H*, 1HL  /
C
C         SET I/O BUFFER POINTERS
C
      ICB0  =  ICBEOL + 1
      ICB1  =  ICBEOL + 1
      ICB2  =  ICBEOL
      IF  (LEMPTY)  GO  TO  20
C
C         IF THE STACK IS NONEMPTY, POP INTO THE I/O BUFFER UNTIL A
C         SUB. CHAR. IS FOUND. THEN CALL MPSUBS.
C
   10 CONTINUE
          CALL  MMPOPC  (CSUB, 5, CTOP, LEMPTY)
          IF  (LEMPTY)  GO  TO  20
          CALL  MPSUBS  (LEOL, LSUBL)
          IF  (LEOL)  GO  TO  999
      GO  TO  10
C
C         IF THE STACK IS EMPTY, GET MORE INPUT
C
   20 CONTINUE
      CALL  IOREAD
      IF  ((.NOT. LSUBL) .OR. (ICB1 .GT. ICB2))  GO  TO  999
C
C         LOOK FOR SUBSTITUTION CHARACTER
C
      DO  30  ICB=ICB1,ICB2
          IF  (CBUFFR(ICB) .EQ. CSUB)  GO  TO  40
   30 CONTINUE
      GO  TO  999
C
C         WHEN A SUB. CHAR IS FOUND, PUT THE VARIABLE '*L' IN THE
C         SYMBOL TABLE.  THE VALUE OF THIS SPECIAL VARIABLE IS THE
C         REST OF THE LINE.  ALSO PUSH *L ONTO THE SUBST. STACK.
C
   40 CONTINUE
      CALL  MMPUTV  (C, 1, ICNDIM, CBUFFR, ICB, ICBEOL)
      CALL  MMPSHV  (C, 1, ICNDIM, 1, LEMPTY, LFOUND)
      ICB2  =  ICB - 1
      CALL  MPSUBS  (LEOL, LSUBL)
      IF  (.NOT. LEOL)  GO  TO  10
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE  MPMAC
C
C-----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     MACRO PROCESSOR
C
C     PURPOSE
C     -------
C     TO DETERMINE THE TYPE OF MACRO EXPANSION INDICATED
C     AND CALL THE APPROPRIATE ROUTINES
C
C-----------------------------------------------------------------------
*INCLUDE(GLCOM)
*INCLUDE(IOCOM)
*INCLUDE(MMCOM)
*INCLUDE(MPCOM)
C
C         LOCAL VARIABLES AND PARAMETERS
C
      $(DECLAREC)         C(12)
      INTEGER             IK(3)
      LOGICAL             LERROR, LFOUND
      DATA
     A     IKYDIM, ICKDIM,
     B     IK(1),  C(1),  C(2),  C(3),
     C     IK(2),  C(4),  C(5),  C(6),  C(7),  C(8),
     D     IK(3),  C(9),  C(10), C(11), C(12)
     E  /  3,      12,
     F     3,      1HD,   1HE,   1HF,
     G     5,      1HL,   1HA,   1HB,   1HE,   1HL,
     H     4,      1HL,   1HI,   1HS,   1HT  /
C
C         MARK THE CURRENT LINE POSITION, POP THE NAME OFF THE STACK,
C         AND THEN DETERMINE THE TYPE OF SUBSTITUTION
C
      ICBSUB  =  ICB2
      CALL  MPPOPN  (ICN1, ICN2, LERROR)
      IF  (LERROR)  GO  TO  999
      CALL  UTRDKY  (CBUFFR, ICN1, ICN2, IK, IKYDIM, C, ICKDIM, I)
      GO  TO  (10, 20,  30,  40),  I
C
C         A DEF SUBSTITUTION HAS BEEN ENCOUNTERED
C
   10 CONTINUE
      CALL  MPPOPN  (ICN1, ICN2, LERROR)
      CALL  MMHASH  (CBUFFR, ICN1, ICN2, IH, LFOUND)
      CALL  UTCVLC  (CBUFFR, ICBSUB, ICB2, ICBDIM, LFOUND, LERROR)
      GO  TO  999
C
C         A LABEL SUBSTITUTION HAS BEEN ENCOUNTERED
C
   20 CONTINUE
      CALL  MPLABL
      GO  TO  999
C
C         A LIST SUBSTITUTION HAS POSSIBLY BEEN ENCOUNTERED
C
   30 CONTINUE
      CALL  MPITEM
      GO  TO  999
C
C         A SIMPLE MACRO SUBSTITUTION HAS BEEN FOUND.
C         PUSH THE NEW NAME ONTO THE STACK
C         AND RESET THE CURRENT LINE POINTER.
C         SUBSEQUENT POPPING OF THE STACK WILL PUT THE VALUE
C         OF THE MACRO INTO THE I/O BUFFER.
C
   40 CONTINUE
      CALL  MMPSHV  (CBUFFR, ICN1, ICN2, 1, LEMPTY, LFOUND)
      IF  (.NOT. LFOUND)  GO  TO  50
      ICB2    =  ICBSUB - 1
      GO  TO  999
C
C         WARNING - NAME NOT FOUND IN SYMBOL TABLE
C
   50 CONTINUE
      CALL  IOERRM  (.FALSE.,
*IF(LIBRARY)
     A 36H(31H +++++++   VARIABLE NOT DEFINED))
*ELSE
     A 46H(41H ********   MPMAC  - VARIABLE NOT DEFINED))
*ENDIF
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE  MPPOPN  (ICN1, ICN2, LERROR)
C
C-----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     MACRO PROCESSOR
C
C     PURPOSE
C     -------
C     TO POP A NAME OFF THE SUBSTITUTION STACK INTO THE I/O BUFFER
C
C     PARAMETERS
C     ----------
C     ICN1    -O-  INDEX IN THE BUFFER OF THE FIRST CHARACTER
C                  IN THE NAME
C     ICN2    -O-  INDEX OF THE LAST CHARACTER
C     LERROR  -O-  TRUE IF THE NAME WAS INVALID
C
C-----------------------------------------------------------------------
*INCLUDE(GLCOM)
*INCLUDE(IOCOM)
*INCLUDE(MMCOM)
*INCLUDE(MPCOM)
C
C         LOCAL VARIABLES AND PARAMETERS
C
      $(DECLAREC)         C
      LOGICAL             L, LEFT, LERROR
C
C         POP BLANKS; LOOK FOR LEFT PAREN.
C
      CALL  MMPOPC  (CBLANK, 4, CTOP, LEMPTY)
      LEFT  =  CLEFT .EQ. CTOP
      IF  (.NOT. LEFT)  GO  TO  10
          CALL  MMPOPC  (C, 2, CTOP, LEMPTY)
          CALL  MMPOPC  (CBLANK, 4, CTOP, LEMPTY)
C
   10 CONTINUE
      ICN1    =  ICB2 + 1
C
C         CHECK FOR A LEGAL NAME
C
*IF(TESTCH)
      LERROR  =  .NOT. ((CA .LE. CTOP) .AND. (CTOP .LE. CZ))
*ELSE
      CALL  UTCHKA  (CTOP, L)
      LERROR  =  .NOT. L
*ENDIF
      IF  (LERROR)  GO  TO  20
C
C         POP THE CHAR'S OF THE NAME OFF
C
      CALL  MMPOPC  (C, 6, CTOP, LEMPTY)
      ICN2  =  ICB2
      IF  (.NOT. LEFT)  GO  TO  999
          CALL  MMPOPC  (CBLANK, 4, CTOP, LEMPTY)
          LERROR  =  CRIGHT .NE. CTOP
          IF  (LERROR)  GO  TO  30
          CALL  MMPOPC  (C, 2, CTOP, LEMPTY)
          GO  TO  999
C
C         WARNING - ILLEGAL NAME
C
   20 CONTINUE
      CALL  IOERRM  (.FALSE.,
*IF(LIBRARY)
     A 37H(32H +++++++   ILLEGAL VARIABLE NAME))
*ELSE
     A 47H(42H ********   MPPOPN - ILLEGAL VARIABLE NAME))
*ENDIF
      GO  TO  999
C
C         WARNING - NO CLOSING RIGHT PARENTHESIS
C
   30 CONTINUE
      CALL  IOERRM  (.FALSE.,
*IF(LIBRARY)
     A 41H(36H +++++++   MISSING RIGHT PARENTHESIS))
*ELSE
     A 51H(46H ********   MPPOPN - MISSING RIGHT PARENTHESIS))
*ENDIF
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE  MPSUBS  (LEOL, LSUBL)
C
C-----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     MACRO PROCESSOR
C
C     PURPOSE
C     -------
C     TO EVALUATE OF THE SUBSTITUTION ESCAPE CHARACTER
C     AND DECIDE WHAT ACTION IS TO BE TAKEN
C
C     PARAMETERS
C     ----------
C     LEOL    -O-  TRUE IF AN END-OF-LINE MARKER WAS FOUND
C     LSUBL   -I-  TRUE IF NO SUBSTITUTION IS TO BE PERFORMED
C                  ON THIS LINE
C
C-----------------------------------------------------------------------
*INCLUDE(GLCOM)
*INCLUDE(IOCOM)
*INCLUDE(MMCOM)
*INCLUDE(MPCOM)
C
C         LOCAL VARIABLES AND PARAMETERS
C
      $(DECLAREC)         C
      LOGICAL             LEOL, LSUBL
C
C         DETERMINE WHAT FOLLOWS THE SUBSTITUTION PREFIX CHARACTER
C
      LEOL  =  .FALSE.
      CALL  MMPOPC  (C, 2, CTOP, LEMPTY)
      IF  (CEOL .EQ. CTOP)              GO  TO  10
      IF  (CEOR .EQ. CTOP)              GO  TO  20
      IF  (CONC .EQ. CTOP)              GO  TO  30
      IF  (.NOT. (LSUB .AND. LSUBL))    GO  TO  999
      IF  (CSUB .EQ. CTOP)              GO  TO  40
      GO  TO  50
C
C         PROCESS AN END-OF-LINE MARKER
C
   10 CONTINUE
      CALL  MPEOL
      LEOL    =  .TRUE.
      GO  TO  999
C
C         PROCESS AN END-OF-RECORD MARKER
C
   20 CONTINUE
      CALL  MMPOPC  (C, 3, CTOP, LEMPTY)
      ICB2  =  ICB2 - 2
      GO  TO  999
C
C         PROCESS A CONTINUATION CHARACTER
C
   30 CONTINUE
      CALL  MMPOPC  (C, 2, CTOP, LEMPTY)
      CALL  MMPOPC  (C, 2, CTOP, LEMPTY)
      CALL  MMPOPC  (C, 2, CTOP, LEMPTY)
      ICB2    =  ICB2 - 4
      GO  TO  999
C
C         PROCESS AN EMBEDDED SUBSTITUTION PREFIX CHARACTER
C
   40 CONTINUE
      CALL  MMPOPC  (C, 2, CTOP, LEMPTY)
      ICB2  =  ICB2 - 1
      GO  TO  999
C
C         A LIST OR MACRO SUBSTITUTION HAS BEEN ENCOUNTERED
C
   50 CONTINUE
      CALL  MPMAC
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE  TPAPPE
C
C-----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     TEMPLATE PROCESSOR
C
C     PURPOSE
C     -------
C     TO PROCESS APPEND DIRECTIVES
C
C-----------------------------------------------------------------------
*INCLUDE(GLCOM)
*INCLUDE(IOCOM)
*INCLUDE(MMCOM)
*INCLUDE(MPCOM)
*INCLUDE(TPCOM)
C
C         LOCAL VARIABLES AND PARAMETERS
C
      $(DECLAREC)         C(15)
      INTEGER             ID(7), IK(3)
      LOGICAL             LERROR
      DATA
     A     IKYDIM, ICKDIM,
     B     IK(1),  C(1),  C(2),  C(3),  C(4),  C(5),  C(6),
     C     IK(2),  C(7),  C(8),  C(9),  C(10), C(11), C(12),
     D     IK(3),  C(13), C(14), C(15)
     E  /  3,      15,
     F     6,      1HA,   1HP,   1HP,   1HE,   1HN,   1HD,
     G     6,      1HE,   1HN,   1HD,   1HA,   1HP,   1HP,
     H     3,      1HE,   1HN,   1HD  /
      DATA
     A     IDSDIM,
     B     ID(1), ID(2), ID(3), ID(4), ID(5), ID(6), ID(7)
     C  /  7,
     D     1,      5,      -3,     6,      6,      2,      7  /
C
C         CHECK SYNTAX
C
      CALL  TPSYNT  (ID, IDSDIM, .FALSE., LERROR)
      IF  (LERROR)        GO  TO  999
      IF  (IARGS .EQ. 2)  GO  TO  10
C
C         PROCESS A MULTI-LINE APPEND STATEMENT
C
      ICBP1(2)  =  ICBEOL + 1
C
C         READ A BLOCK; UNTIL *ENDAPP
C
      CALL  TPRDBL  (IK, IKYDIM, C, ICKDIM, ID, IDSDIM,
     A                           .TRUE., .FALSE., .TRUE., LERROR)
      IF  (LEND)    GO  TO  20
      IF  (LERROR)  GO  TO  999
      ICBP2(2)  =  ICB0 - 1
C
C         APPEND THE VALUE
C
   10 CONTINUE
      CALL  MMAPPV  (CBUFFR, ICBP1(1), ICBP2(1),
     A               CBUFFR, ICBP1(2), ICBP2(2))
      GO  TO  999
C
   20 CONTINUE
      CALL  IOERRM  (.FALSE.,
*IF(LIBRARY)
     A 45H(40H +++++++   APPEND HAS NO MATCHING ENDAPP))
*ELSE
     A 55H(50H ********   TPAPPE - APPEND HAS NO MATCHING ENDAPP))
*ENDIF
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE  TPCHKD
C
C-----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     TEMPLATE PROCESSOR
C
C     PURPOSE
C     -------
C     TO DETERMINE IF A LINE CONTAINS A DIRECTIVE
C
C-----------------------------------------------------------------------
*INCLUDE(GLCOM)
*INCLUDE(IOCOM)
*INCLUDE(MMCOM)
*INCLUDE(MPCOM)
*INCLUDE(TPCOM)
C
C         LOCAL VARIABLES AND PARAMETERS
C
      LOGICAL             LEOL
C
      LDIRL  =  .FALSE.
      IF  (ICB1 .GT. ICB2)          GO  TO  999
      IF  (CBUFFR(ICB1) .EQ. CDIR)  GO  TO  10
      IF  (LCOL1)                   GO  TO  999
      CALL  UTRDBL  (CBUFFR, ICB1, ICB2, LEOL)
      IF  (LEOL)                    GO  TO  999
      IF  (CBUFFR(ICB1) .NE. CDIR)  GO  TO  999
C
   10 CONTINUE
      ICB1   =  ICB1 + 1
      LDIRL  =  .TRUE.
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE  TPCOMM
C
C-----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     TEMPLATE PROCESSOR
C
C     PURPOSE
C     -------
C     TO PROCESS COMMENT DIRECTIVES
C
C-----------------------------------------------------------------------
*INCLUDE(GLCOM)
*INCLUDE(IOCOM)
*INCLUDE(MMCOM)
*INCLUDE(MPCOM)
*INCLUDE(TPCOM)
C
C         LOCAL VARIABLES AND PARAMETERS
C
      $(DECLAREC)         C(16)
      INTEGER             ID(1), IK(3)
      LOGICAL             LERROR
      DATA                IDSDIM, ID(1)  /  1, 7  /
      DATA
     A     IKYDIM, ICKDIM,
     B     IK(1),  C(1),  C(2),  C(3),  C(4),  C(5),  C(6),  C(7),
     C     IK(2),  C(8),  C(9),  C(10), C(11), C(12), C(13),
     D     IK(3),  C(14), C(15), C(16)
     E  /  3,      16,
     F     7,      1HC,   1HO,   1HM,   1HM,   1HE,   1HN,   1HT,
     G     6,      1HE,   1HN,   1HD,   1HC,   1HO,   1HM,
     H     3,      1HE,   1HN,   1HD  /
C
C         CHECK SYNTAX
C
      CALL  TPSYNT  (ID, IDSDIM, .FALSE., LERROR)
      IF  (LERROR)  GO  TO  999
C
C         READ A BLOCK; UNTIL *ENDCOM
C
      CALL  TPRDBL  (IK, IKYDIM, C, ICKDIM, ID, IDSDIM,
     A                           .FALSE., .TRUE., .FALSE., LERROR)
      IF  (.NOT. LEND)  GO  TO  999
C
C         AN -END- HAS POSSIBLY BEEN ENCOUNTERED
C
      CALL  IOERRM  (.FALSE.,
*IF(LIBRARY)
     A 46H(41H +++++++   COMMENT HAS NO MATCHING ENDCOM))
*ELSE
     A 56H(51H ********   TPCOMM - COMMENT HAS NO MATCHING ENDCOM))
*ENDIF
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE  TPDELE
C
C-----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     TEMPLATE PROCESSOR
C
C     PURPOSE
C     -------
C     TO PROCESS DELETE DIRECTIVES
C
C-----------------------------------------------------------------------
*INCLUDE(GLCOM)
*INCLUDE(IOCOM)
*INCLUDE(MMCOM)
*INCLUDE(MPCOM)
*INCLUDE(TPCOM)
C
C         LOCAL VARIABLES AND PARAMETERS
C
      INTEGER             ID(4)
      LOGICAL             LERROR, LFOUND
      DATA                IDSDIM, ID(1), ID(2), ID(3), ID(4)
     A                 /  4,      1,     5,     2,     7  /
C
C         CHECK SYNTAX
C
      CALL  TPSYNT  (ID, IDSDIM, .FALSE., LERROR)
      IF  (LERROR)  GO  TO  999
C
C         DELETE THE VARIABLE
C
      CALL  MMDELV  (CBUFFR, ICBP1(1), ICBP2(1), LFOUND)
C
  999 CONTINUE
      RETURN
      END
 
      SUBROUTINE  TPDO
C
C-----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     TEMPLATE PROCESSOR
C
C     PURPOSE
C     -------
C     TO PROCESS DO DIRECTIVES
C
C-----------------------------------------------------------------------
*INCLUDE(GLCOM)
*INCLUDE(IOCOM)
*INCLUDE(MMCOM)
*INCLUDE(MPCOM)
*INCLUDE(TPCOM)
C
C         LOCAL VARIABLES AND PARAMETERS
C
      $(DECLAREC)         C(10), CD(1), CIN(1)
      INTEGER             ID(11), IK(3)
      LOGICAL             LERROR, LFOUND
      DATA                ICDDIM, CD(1)  /  1, 1HD  /
      DATA                ICIDIM, CIN(1)  /  1, 1HI  /
      DATA
     A     IKYDIM, ICKDIM,
     B     IK(1),  C(1),  C(2),
     C     IK(2),  C(3),  C(4),  C(5),  C(6),  C(7),
     D     IK(3),  C(8),  C(9),  C(10)
     E  /  3,      10,
     F     2,      1HD,   1HO,
     G     5,      1HE,   1HN,   1HD,   1HD,   1HO,
     H     3,      1HE,   1HN,   1HD  /
      DATA
     A     IDSDIM,
     B     ID(1),  ID(2),  ID(3),  ID(4),  ID(5),
     C     ID(6),  ID(7),  ID(8),  ID(9),  ID(10), ID(11)
     D  /  11,
     E     1,       5,       4,       6,       3,
     F     6,       -3,      10,      6,       2,       7  /
C
C         CHECK SYNTAX
C
      CALL  TPSYNT  (ID, IDSDIM, .FALSE., LERROR)
      IF  (LERROR)  GO  TO  999
      INESTD  =  INESTD + 1
      ICN1    =  ICBEND + 1
C
C         GET LOOP INDEX AND LOOP PARAMETERS
C
      CALL  UTBLDN  (CSTAR, CIN, 1, ICIDIM, INESTD,
     A               CBUFFR, ICN1, ICN2, ICBDIM, LERROR)
      ICBEND  =  ICN2
      CALL  MMPUTV  (CBUFFR, ICN1,     ICN2,
     A               CBUFFR, ICBP1(1), ICBP2(1))
      CALL  MMPUTV  (CBUFFR, ICBP1(1), ICBP2(1),
     A               CBUFFR, ICBP1(2), ICBP2(2))
      CALL  UTCVCI  (CBUFFR, ICBP1(2), ICBP2(2), I1, LERROR)
      CALL  UTCVCI  (CBUFFR, ICBP1(3), ICBP2(3), I2, LERROR)
      I3      =  1
      IF  (IARGS .EQ. 4)
     A    CALL  UTCVCI  (CBUFFR, ICBP1(4), ICBP2(4), I3, LERROR)
      IF  (L1TRIP .OR. ((I2-I1)*ISIGN(1,I3) .GE. 0))  GO  TO  10
          CALL  TPRDBL  (IK, IKYDIM, C, ICKDIM, ID, IDSDIM,
     A                               .FALSE., .TRUE., .FALSE., LERROR)
          IF  (LEND)  GO  TO  30
          INESTD  =  INESTD - 1
          GO  TO  999
C
   10 CONTINUE
      CALL  MMNEWI  (ITEMP)
      ISTORE(ITEMP)    =  I2
      ISTORE(ITEMP+1)  =  I3
      ISTORE(ITEMP+2)  =  ITOPDO
      ITOPDO           =  ITEMP
      IF  (INESTD .GT. 1)  GO  TO  20
          CALL  UTBLDN  (CSTAR, CD, 1, ICDDIM, -1,
     A                   CBUFFR, 1, ICN2, ICBDIM, LERROR)
          ICBEOL  =  ICN2
          ICV1    =  ICN2 + 1
C
C         READ A BLOCK UNTIL *ENDDO.  PUSH CONTENTS OF DO RANGE
C         ONTO STACK.
C
          CALL  TPRDBL  (IK, IKYDIM, C, ICKDIM, ID, IDSDIM,
     A                               .FALSE., .FALSE., .FALSE., LERROR)
          IF  (LEND)  GO  TO  30
          CALL  MMPUTV  (CBUFFR, 1, ICN2, CBUFFR, ICV1, ICBEOL)
          CALL  MMPSHV  (CBUFFR, 1, ICN2, 1, LEMPTY, LFOUND)
C
   20 CONTINUE
      CALL  UTBLDN  (CSTAR, CD, 1, ICDDIM, INESTD,
     A               CBUFFR, 1, ICN2, ICBDIM, LERROR)
      CALL  MMSETP  (CBUFFR, 1, ICN2)
      GO  TO  999
C
C         WARNING - MATCHING ENDDO NOT FOUND
C
   30 CONTINUE
      CALL  IOERRM  (.FALSE.,
*IF(LIBRARY)
     A 40H(35H +++++++   DO HAS NO MATCHING ENDDO))
*ELSE
     A 50H(45H ********   TPDO   - DO HAS NO MATCHING ENDDO))
*ENDIF
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE  TPELSE
C
C-----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     TEMPLATE PROCESSOR
C
C     PURPOSE
C     -------
C     TO PROCESS ELSE DIRECTIVES
C
C-----------------------------------------------------------------------
*INCLUDE(GLCOM)
*INCLUDE(IOCOM)
*INCLUDE(MMCOM)
*INCLUDE(MPCOM)
*INCLUDE(TPCOM)
C
C         LOCAL VARIABLES AND PARAMETERS
C
      $(DECLAREC)         C(10)
      INTEGER             ID(1), IDIF(4), IK(3)
      LOGICAL             LERROR
      DATA                IDSDIM, ID(1)  /  1, 7  /
      DATA
     A     IDSDIF,
     B     IDIF(1), IDIF(2), IDIF(3), IDIF(4)
     C  /  4,
     D     1,        6,        2,        8  /
      DATA
     A     IKYDIM, ICKDIM,
     B     IK(1),  C(1),  C(2),
     C     IK(2),  C(3),  C(4),  C(5),  C(6),  C(7),
     D     IK(3),  C(8),  C(9),  C(10)
     E  /  3,      10,
     F     2,      1HI,   1HF,
     G     5,      1HE,   1HN,   1HD,   1HI,   1HF,
     H     3,      1HE,   1HN,   1HD  /
C
C         CHECK SYNTAX
C
      CALL  TPSYNT  (ID, IDSDIM, .FALSE., LERROR)
      IF  (LERROR)  GO  TO  999
      INESTF  =  INESTF - 1
      CALL  TPRDBL  (IK, IKYDIM, C, ICKDIM, IDIF, IDSDIF,
     A                           .TRUE., .TRUE., .FALSE., LERROR)
      IF  (.NOT. LEND)  GO  TO  999
C
C         AN -END- HAS BEEN ENCOUNTERED
C
      CALL  IOERRM  (.FALSE.,
*IF(LIBRARY)
     A 40H(35H +++++++   IF HAS NO MATCHING ENDIF))
*ELSE
     A 50H(45H ********   TPELSE - IF HAS NO MATCHING ENDIF))
*ENDIF
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE  TPENDO
C
C-----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     TEMPLATE PROCESSOR
C
C     PURPOSE
C     -------
C     TO PROCESS ENDDO DIRECTIVES
C
C-----------------------------------------------------------------------
*INCLUDE(GLCOM)
*INCLUDE(IOCOM)
*INCLUDE(MMCOM)
*INCLUDE(MPCOM)
*INCLUDE(TPCOM)
C
C         LOCAL VARIABLES
C
      $(DECLAREC)         CD(1), CIN(1)
      INTEGER             ID(1)
      LOGICAL             LERROR, LFOUND
      DATA                ICDDIM, CD(1)  /  1, 1HD  /
      DATA                ICIDIM, CIN(1)  /  1, 1HI  /
      DATA                IDSDIM, ID(1)  /  1, 7  /
C
C         CHECK SYNTAX
C
      CALL  TPSYNT  (ID, IDSDIM, .FALSE., LERROR)
      IF  (LERROR)  GO  TO  999
      IF  (INESTD .LE. 0)  GO  TO  20
      CALL  UTBLDN  (CSTAR, CIN, 1, ICIDIM, INESTD,
     A               CBUFFR, 1, ICN2, ICBDIM, LERROR)
      CALL  MMGETV  (CBUFFR, 1, ICN2, CBUFFR, 1, ICV2, ICBDIM, LFOUND)
      ICN2  =  ICV2
      ICV1  =  ICV2 + 1
      CALL  MMGETV  (CBUFFR, 1, ICN2,
     A               CBUFFR, ICV1, ICV2, ICBDIM, LFOUND)
      CALL  UTCVCI  (CBUFFR, ICV1, ICV2, I, LERROR)
      I2    =  ISTORE(ITOPDO)
      I3    =  ISTORE(ITOPDO+1)
      I     =  I + I3
      IF  ((I2-I)*ISIGN(1,I3) .LT. 0)  GO  TO  10
          CALL  UTCVIC  (CBUFFR, ICV1, ICV2, ICBDIM, I, LERROR)
          CALL  MMPUTV  (CBUFFR, 1, ICN2, CBUFFR, ICV1, ICV2)
          CALL  UTBLDN  (CSTAR, CD, 1, ICDDIM, INESTD,
     A                   CBUFFR, 1, ICN2, ICBDIM, LERROR)
          IF  (INESTD .GT. 1)  CALL  MMPOPV  (LEMPTY)
          CALL  MMPSHV  (CBUFFR, 1, ICN2, 2, LEMPTY, LFOUND)
          GO  TO  999
C
   10 CONTINUE
      INESTD  =  INESTD - 1
      ITEMP   =  ITOPDO
      ITOPDO  =  ISTORE(ITOPDO+2)
      CALL  MMRETI  (ITEMP)
      GO  TO  999
C
   20 CONTINUE
      CALL  IOERRM  (.FALSE.,
*IF(LIBRARY)
     A 31H(26H +++++++   MISPLACED ENDDO))
*ELSE
     A 41H(36H ********   TPENDO - MISPLACED ENDDO))
*ENDIF
C
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE  TPENDF
C
C-----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     TEMPLATE PROCESSOR
C
C     PURPOSE
C     -------
C     TO PROCESS ENDIF DIRECTIVES
C
C-----------------------------------------------------------------------
*INCLUDE(GLCOM)
*INCLUDE(IOCOM)
*INCLUDE(MMCOM)
*INCLUDE(MPCOM)
*INCLUDE(TPCOM)
C
C         LOCAL VARIABLES
C
      INTEGER             ID(1)
      LOGICAL             LERROR
      DATA                IDSDIM, ID(1)  /  1, 7  /
C
C         CHECK SYNTAX
C
      CALL  TPSYNT  (ID, IDSDIM, .FALSE., LERROR)
      IF  (LERROR)  GO  TO  999
      IF  (INESTF .LE. 0)  GO  TO  10
      INESTF  =  INESTF - 1
      GO  TO  999
C
   10 CONTINUE
      CALL  IOERRM  (.FALSE.,
*IF(LIBRARY)
     A 31H(26H +++++++   MISPLACED ENDIF))
*ELSE
     A 41H(36H ********   TPENDF - MISPLACED ENDIF))
*ENDIF
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE  TPEVAL
C
C-----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     TEMPLATE PROCESSOR
C
C     PURPOSE
C     -------
C     TO CALL ROUTINES TO PROCESS DIRECTIVES
C
C-----------------------------------------------------------------------
*INCLUDE(GLCOM)
*INCLUDE(IOCOM)
*INCLUDE(MMCOM)
*INCLUDE(MPCOM)
*INCLUDE(TPCOM)
C
C         LOCAL VARIABLES
C
      $(DECLAREC)         C(79)
      INTEGER             IK(16)
      DATA
     A     IKYDIM, ICKDIM,
     B     IK(1),  C(1),  C(2),  C(3),  C(4),  C(5),  C(6),
     C     IK(2),  C(7),  C(8),  C(9),  C(10), C(11), C(12), C(13),
     D     IK(3),  C(14), C(15), C(16), C(17), C(18), C(19),
     E     IK(4),  C(20), C(21),
     F     IK(5),  C(22), C(23), C(24), C(25),
     G     IK(6),  C(26), C(27), C(28), C(29), C(30),
     H     IK(7),  C(31), C(32), C(33), C(34), C(35),
     I     IK(8),  C(36), C(37)
     J  /  16,     79,
     K     6,      1HA,   1HP,   1HP,   1HE,   1HN,   1HD,
     L     7,      1HC,   1HO,   1HM,   1HM,   1HE,   1HN,   1HT,
     M     6,      1HD,   1HE,   1HL,   1HE,   1HT,   1HE,
     N     2,      1HD,   1HO,
     O     4,      1HE,   1HL,   1HS,   1HE,
     P     5,      1HE,   1HN,   1HD,   1HD,   1HO,
     Q     5,      1HE,   1HN,   1HD,   1HI,   1HF,
     R     2,      1HI,   1HF  /
      DATA
     A     IK(9),  C(38), C(39), C(40), C(41), C(42), C(43), C(44),
     B     IK(10), C(45), C(46), C(47), C(48), C(49), C(50),
     C     IK(11), C(51), C(52), C(53), C(54), C(55),
     D     IK(12), C(56), C(57), C(58),
     E     IK(13), C(59), C(60), C(61), C(62), C(63), C(64),
     F     IK(14), C(65), C(66), C(67), C(68), C(69), C(70),
     G     IK(15), C(71), C(72), C(73), C(74), C(75), C(76),
     H     IK(16), C(77), C(78), C(79)
     I  /  7,      1HI,   1HN,   1HC,   1HL,   1HU,   1HD,   1HE,
     J     6,      1HO,   1HP,   1HT,   1HI,   1HO,   1HN,
     K     5,      1HR,   1HE,   1HS,   1HE,   1HT,
     L     3,      1HS,   1HE,   1HT,
     M     6,      1HE,   1HN,   1HD,   1HA,   1HP,   1HP,
     N     6,      1HE,   1HN,   1HD,   1HC,   1HO,   1HM,
     O     6,      1HE,   1HN,   1HD,   1HS,   1HE,   1HT,
     P     3,      1HE,   1HN,   1HD  /
C
      ICB1    =  ICB0
      ICB2    =  ICB3
      CALL  TPCHKD
      IF  (.NOT. LDIRL)  GO  TO  999
C
C         A DIRECTIVE LINE HAS BEEN FOUND.  CHECK WHICH ONE IT IS
C
      CALL  UTRDKY  (CBUFFR, ICB1, ICB2, IK, IKYDIM, C, ICKDIM, I)
      GO  TO  (10,  20,  30,  40,  50,  60,  70,  80,  90,
     A              100, 110, 120, 130, 140, 150, 160, 170),  I
C
C         PROCESS -APPEND-
C
   10 CONTINUE
      CALL  TPAPPE
      GO  TO  999
C
C         PROCESS -COMMENT-
C
   20 CONTINUE
      CALL  TPCOMM
      GO  TO  999
C
C         PROCESS -DELETE-
C
   30 CONTINUE
      CALL  TPDELE
      GO  TO  999
C
C         PROCESS -DO-
C
   40 CONTINUE
      CALL  TPDO
      GO  TO  999
C
C         PROCESS -ELSE-
C
   50 CONTINUE
      CALL  TPELSE
      GO  TO  999
C
C         PROCESS -ENDDO-
C
   60 CONTINUE
      CALL  TPENDO
      GO  TO  999
C
C         PROCESS -ENDIF-
C
   70 CONTINUE
      CALL  TPENDF
      GO  TO  999
C
C         PROCESS -IF-
C
   80 CONTINUE
      CALL  TPIF
      GO  TO  999
C
C         PROCESS -INCLUDE-
C
   90 CONTINUE
      CALL  TPINCL
      GO  TO  999
C
C         PROCESS -OPTION-
C
  100 CONTINUE
      CALL  TPOPT
      GO  TO  999
C
C         PROCESS -RESET-
C
  110 CONTINUE
      CALL  TPRSET
      GO  TO  999
C
C         PROCESS -SET-
C
  120 CONTINUE
      CALL  TPSET
      GO  TO  999
C
C         PROCESS -ENDAPP-
C
  130 CONTINUE
      CALL  IOERRM  (.FALSE.,
*IF(LIBRARY)
     A 32H(27H +++++++   MISPLACED ENDAPP))
*ELSE
     A 42H(37H ********   TPEVAL - MISPLACED ENDAPP))
*ENDIF
      GO  TO  999
C
C         PROCESS -ENDCOM-
C
  140 CONTINUE
      CALL  IOERRM  (.FALSE.,
*IF(LIBRARY)
     A 32H(27H +++++++   MISPLACED ENDCOM))
*ELSE
     A 42H(37H ********   TPEVAL - MISPLACED ENDCOM))
*ENDIF
      GO  TO  999
C
C         PROCESS -ENDSET-
C
  150 CONTINUE
      CALL  IOERRM  (.FALSE.,
*IF(LIBRARY)
     A 32H(27H +++++++   MISPLACED ENDSET))
*ELSE
     A 42H(37H ********   TPEVAL - MISPLACED ENDSET))
*ENDIF
      GO  TO  999
C
C         PROCESS -END-
C
  160 CONTINUE
      LEND  =  .TRUE.
      GO  TO  999
C
C         PROCESS UNRECOGNIZED DIRECTIVES
C
  170 CONTINUE
      CALL  IOERRM  (.FALSE.,
*IF(LIBRARY)
     A 47H(42H +++++++   ILLEGAL OR MISSPELLED DIRECTIVE))
*ELSE
     A 57H(52H ********   TPEVAL - ILLEGAL OR MISSPELLED DIRECTIVE))
*ENDIF
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE  TPEXPR  (ICV1, ICV2, LSCAN, LERROR)
C
C-----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     TEMPLATE PROCESSOR
C
C     PURPOSE
C     -------
C     TO DETERMINE IF AN EXPRESSION IS VALID AND RETURN ITS VALUE.
C     CURRENTLY, EXPRESSIONS MAY CONSIST ONLY OF VARIABLES OR CONSTANTS.
C
C     PARAMETERS
C     ----------
C     ICV1    -I-  INDEX INTO CBUFFR OF THE FIRST
C                  CHARACTER IN THE EXPRESSION
C     ICV2    -I-  INDEX OF THE LAST CHARACTER
C     LSCAN   -I-  IF TRUE, THEN VALIDATE (SCAN) BUT DO NOT EVALUATE
C     LERROR  -O-  TRUE IF THE EXPRESSION WAS INVALID
C
C-----------------------------------------------------------------------
*INCLUDE(GLCOM)
*INCLUDE(IOCOM)
*INCLUDE(MMCOM)
*INCLUDE(MPCOM)
*INCLUDE(TPCOM)
C
C         LOCAL VARIABLES AND PARAMETERS
C
      LOGICAL             L, LERROR, LSCAN
C
*IF(TESTCH)
      IF  ((CA .LE. CBUFFR(ICB1)) .AND.
     A     (CBUFFR(ICB1) .LE. CZ))    GO  TO  10
      IF  ((C0 .LE. CBUFFR(ICB1)) .AND.
     A     (CBUFFR(ICB1) .LE. C9))    GO  TO  20
*ELSE
      CALL  UTCHKA  (CBUFFR(ICB1), L)
      IF  (L)  GO  TO  10
      CALL  UTCHKN  (CBUFFR(ICB1), L)
      IF  (L)  GO  TO  20
*ENDIF
      IF  (CBUFFR(ICB1) .EQ. CMINUS)  GO  TO  20
      IF  (CBUFFR(ICB1) .EQ. CPLUS)   GO  TO  20
      IF  (CBUFFR(ICB1) .EQ. CQUOTE)  GO  TO  30
      IF  (CBUFFR(ICB1) .EQ. CPOINT)  GO  TO  40
      LERROR  =  .TRUE.
      GO  TO  999
C
C         PROCESS A NAME
C
   10 CONTINUE
      CALL  UTRDNA  (CBUFFR, ICB1, ICB2, ICN1, ICN2, LERROR)
      IF  (LERROR)  GO  TO  999
      IF  (LSCAN)   GO  TO  999
      ICV1    =  ICBEND + 1
      CALL  MMGETV  (CBUFFR, ICN1, ICN2, CBUFFR, ICV1, ICV2, ICBDIM, L)
      ICBEND  =  ICV2
      LERROR  =  .NOT. L
      GO  TO  999
C
C         PROCESS A NUMBER
C
   20 CONTINUE
      CALL  UTRDNU  (CBUFFR, ICB1, ICB2, ICV1, ICV2, LERROR)
      GO  TO  999
C
C         PROCESS A QUOTED STRING
C
   30 CONTINUE
      CALL  UTRDQS  (CBUFFR, ICB1, ICB2, ICV1, ICV2, LERROR)
      GO  TO  999
C
C         PROCESS A LOGICAL CONSTANT
C
   40 CONTINUE
      CALL  UTRDQS  (CBUFFR, ICB1, ICB2, ICV1, ICV2, LERROR)
      IF  (LERROR)  GO  TO  999
      ICV1  =  ICV1 - 1
      ICV2  =  ICV2 + 1
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE  TPIF
C
C-----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     TEMPLATE PROCESSOR
C
C     PURPOSE
C     -------
C     TO PROCESS IF DIRECTIVES
C
C-----------------------------------------------------------------------
*INCLUDE(GLCOM)
*INCLUDE(IOCOM)
*INCLUDE(MMCOM)
*INCLUDE(MPCOM)
*INCLUDE(TPCOM)
C
C         LOCAL VARIABLES AND PARAMETERS
C
      $(DECLAREC)         C(14), CN(2)
      INTEGER             ID(7), IK(4)
      LOGICAL             LERROR, LFOUND, LVALUE
      DATA                ICNDIM, CN(1), CN(2)  /  2, 1H*, 1HF  /
      DATA
     A     IKYDIM, ICKDIM,
     B     IK(1),  C(1),  C(2),
     C     IK(2),  C(3),  C(4),  C(5),  C(6),
     D     IK(3),  C(7),  C(8),  C(9),  C(10), C(11),
     E     IK(4),  C(12), C(13), C(14)
     F  /  4,      14,
     G     2,      1HI,   1HF,
     H     4,      1HE,   1HL,   1HS,   1HE,
     I     5,      1HE,   1HN,   1HD,   1HI,   1HF,
     J     3,      1HE,   1HN,   1HD  /
      DATA    IDSDIM, ID(1), ID(2), ID(3), ID(4), ID(5), ID(6), ID(7)
     A          /  7,    1,     6,    -4,     6,     6,     2,     8 /
C
C         CHECK SYNTAX
C
      CALL  TPSYNT  (ID, IDSDIM, .FALSE., LERROR)
      IF  (LERROR)  GO  TO  999
      IF ((IARGS .EQ. 3) .OR.
     A    ((IARGS .EQ. 2) .AND. (ICBEOL.NE.ICBP2(2))))  GO TO 3
C
C       HAVE FOUND FORM: '*IF(L)'
C
  CALL  UTCVCL  (CBUFFR, ICBP1(1), ICBP2(1), LVALUE, LERROR)
  IF (IARGS .EQ. 1)  GO TO 10
  GO TO 9
    3 CONTINUE
C
C       HAVE FOUND FORM: '*IF(EXP1=EXP2)'
C
  LVALUE = .FALSE.
  LEN1 = ICBP2(1) - ICBP1(1) + 1
  LEN2 = ICBP2(2) - ICBP1(2) + 1
  IF (LEN1 .NE. LEN2)  GO TO 8
  I1 = ICBP1(1)
  I2 = ICBP1(2)
  DO 5 I = 1, LEN1
    IF (CBUFFR(I1) .NE. CBUFFR(I2)) GO TO 8
    I1 = I1 + 1
    I2 = I2 + 1
    5   CONTINUE
  LVALUE = .TRUE.
    8 CONTINUE
      IF (IARGS .EQ. 2) GO TO 10
C
C
C         PROCESS A ONE-LINE IF STATEMENT
C
    9 CONTINUE
      IF  (.NOT. LVALUE)       GO  TO  999
      CALL  MMPUTV  (CN, 1, ICNDIM, CBUFFR, ICBP1(IARGS), ICBP2(IARGS))
      CALL  MMPSHV  (CN, 1, ICNDIM, 1, LEMPTY, LFOUND)
      GO  TO  999
C
C         PROCESS A MULTI-LINE IF STATEMENT
C
   10 CONTINUE
      INESTF  =  INESTF + 1
      IF  (LVALUE)  GO  TO  999
      INEST   =  INESTF
C
   20 CONTINUE
          CALL  MPLINE   (.FALSE.)
          CALL  TPCHKD
          IF  (.NOT. LDIRL)  GO  TO  20
          CALL  UTRDKY  (CBUFFR, ICB1, ICB2, IK, IKYDIM, C, ICKDIM, I)
      GO  TO  (30,  40,  50,  60,  20),  I
C
C         AN -IF- HAS BEEN ENCOUNTERED
C
   30 CONTINUE
      CALL  TPSYNT  (ID, IDSDIM, .TRUE., LERROR)
      IF  (IARGS .EQ. 1)  INESTF  =  INESTF + 1
C
C             IF IARGS=2 AND ICB1 > ICB2, ASSUME
C             DIRECTIVE IS OF FORM   '*IF(ARG1 = ARG2)'
C
      IF  ((IARGS .EQ. 2) .AND. (ICB1 .GT. ICB2))  INESTF = INESTF + 1
      GO  TO  20
C
C         AN -ELSE- HAS BEEN ENCOUNTERED
C
   40 CONTINUE
      IF  (INESTF .LE. INEST)  GO  TO  999
      GO  TO  20
C
C         AN -ENDIF- HAS BEEN ENCOUNTERED
C
   50 CONTINUE
      INESTF  =  INESTF - 1
      IF  (INESTF .LT. INEST)  GO  TO  999
      GO  TO  20
C
C         AN -END- HAS POSSIBLY BEEN ENCOUNTERED
C
   60 CONTINUE
      LEND  =  ICB1 .GT. ICB2
      IF  (.NOT. LEND)  GO  TO  20
      CALL  IOERRM  (.FALSE.,
*IF(LIBRARY)
     A 40H(35H +++++++   IF HAS NO MATCHING ENDIF))
*ELSE
     A 50H(45H ********   TPIF   - IF HAS NO MATCHING ENDIF))
*ENDIF
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE  TPINCL
C
C-----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     TEMPLATE PROCESSOR
C
C     PURPOSE
C     -------
C     TO PROCESS INCLUDE DIRECTIVES
C
C-----------------------------------------------------------------------
*INCLUDE(GLCOM)
*INCLUDE(IOCOM)
*INCLUDE(MMCOM)
*INCLUDE(MPCOM)
*INCLUDE(TPCOM)
C
C         LOCAL VARIABLES AND PARAMETERS
C
      INTEGER             ID(4)
      LOGICAL             LERROR, LFOUND
      DATA                IDSDIM, ID(1), ID(2), ID(3), ID(4)
     A                 /  4,      1,     5,     2,     8  /
C
C         CHECK SYNTAX, AND PUSH THE VARIABLE ON THE STACK
C
      CALL  TPSYNT  (ID, IDSDIM, .FALSE., LERROR)
      IF  (LERROR)  GO  TO  999
      CALL  MMPSHV  (CBUFFR, ICBP1(1), ICBP2(1), 1, LEMPTY, LFOUND)
      IF  (LFOUND)  GO  TO  999
      CALL  IOERRM  (.FALSE.,
*IF(LIBRARY)
     A 36H(31H +++++++   VARIABLE NOT DEFINED))
*ELSE
     A 46H(41H ********   TPINCL - VARIABLE NOT DEFINED))
*ENDIF
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE  TPINIT  (IUE0, IUI0, IUL0, IUO0)
C
C-----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     TEMPLATE PROCESSOR
C
C     PURPOSE
C     -------
C     TO INITIALIZE TEMPLATE PROCESSOR VATIABLES
C
C     PARAMETERS
C     ----------
C     IUE0    -I-  UNIT NUMBER OF THE ERROR FILE
C     IUI0    -I-  UNIT NUMBER OF THE INPUT FILE
C     IUL0    -I-  UNIT NUMBER OF THE LISTING FILE
C     IUO0    -I-  UNIT NUMBER OF THE OUTPUT FILE
C
C-----------------------------------------------------------------------
*INCLUDE(GLCOM)
*INCLUDE(IOCOM)
*INCLUDE(MMCOM)
*INCLUDE(MPCOM)
*INCLUDE(TPCOM)
C
      IUNITE  =  IUE0
      IUNITI  =  IUI0
      IUNITL  =  IUL0
      IUNITO  =  IUO0
C
      ILNMBR  =  0
      ILCTR   =  ILPP
      INESTD  =  0
      INESTF  =  0
      IPAGE   =  0
      ITOPDO  =  0
      LEMPTY  =  .TRUE.
      LEND    =  .FALSE.
      IF  (.NOT. LINITM)  CALL  MMINIT
      LINITM  =  .TRUE.
C
      RETURN
      END
      SUBROUTINE  TPMMIN
C
C----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     TEMPLATE PROCESSOR
C
C     PURPOSE
C     -------
C     THIS ROUTINE INITIALIZES TEMPLATE PROCESSOR CONSTANTS.
C
C----------------------------------------------------------------------
*INCLUDE(GLCOM)
*INCLUDE(IOCOM)
*INCLUDE(MMCOM)
*INCLUDE(MPCOM)
*INCLUDE(TPCOM)
C
      $(DECLAREC)       CA0,      CBLAN0,   CC0,      CI0,      CLEFT0,
     A                  CMINU0,   CPLUS0,   CPOIN0,   CQUOT0,   CRIGH0,
     B                  CZ0,      C00,      C90,
     C                  CDIR0,    CDIV0,    CEOL0,    CEOR0,   CONC0,
     D                  CSTAR0,   CSUB0
      DATA              CA0,      CBLAN0,   CC0,      CI0,      CLEFT0,
     A                  CMINU0,   CPLUS0,   CPOIN0,   CQUOT0,   CRIGH0,
     B                  CZ0,      C00,      C90
     C               /  1HA,      1H ,      1HC,      1HI,      1H(,
     D                  1H-,      1H+,      1H.,      1H',      1H),
     E                  1HZ,      1H0,      1H9  /
      DATA      CDIR0       /  1H*      /
      DATA      CDIV0       /  1H/      /
      DATA      CEOL0       /  1H-      /
      DATA      CEOR0       /  1H/      /
      DATA      CONC0       /  1H+      /
      DATA      CSTAR0      /  1H*      /
*OPTION(LSUB=.FALSE.)
      DATA      CSUB0       /  1H$      /
*OPTION(LSUB=.TRUE.)
      CA       =  CA0
      CBLANK   =  CBLAN0
      CC       =  CC0
      CI       =  CI0
      CLEFT    =  CLEFT0
      CMINUS   =  CMINU0
      CPLUS    =  CPLUS0
      CPOINT   =  CPOIN0
      CQUOTE   =  CQUOT0
      CRIGHT   =  CRIGH0
      CZ       =  CZ0
      C0       =  C00
      C9       =  C90
C
      CDIR     =  CDIR0
      CDIV     =  CDIV0
      CEOL     =  CEOL0
      CEOR     =  CEOR0
      CONC     =  CONC0
      CSTAR    =  CSTAR0
      CSUB     =  CSUB0
C
      ICBADD   =  1
      ICPLI    =  72
      ICPLO    =  72
      ILPP     =  58
      LBREAK   =  .FALSE.
      LCOL1    =  .FALSE.
      LFORT    =  .FALSE.
      LINITM   =  .FALSE.
      LISTI    =  .FALSE.
      LISTO    =  .FALSE.
      LSUB     =  .TRUE.
      L1TRIP   =  .TRUE.
C
      RETURN
      END
      SUBROUTINE  TPOPT
C
C-----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     TEMPLATE PROCESSOR
C
C     PURPOSE
C     -------
C     TO PROCESS OPTION DIRECTIVES
C
C-----------------------------------------------------------------------
*INCLUDE(GLCOM)
*INCLUDE(IOCOM)
*INCLUDE(MMCOM)
*INCLUDE(MPCOM)
*INCLUDE(TPCOM)
C
C         LOCAL VARIABLES AND PARAMETERS
C
      $(DECLAREC)         C(84), CVALUE
      INTEGER             ID(6), IK(17)
      LOGICAL             LERROR, LVALUE
      DATA
     A     IKYDIM, ICKDIM,
     B     IK(1),  C(1),  C(2),  C(3),  C(4),
     C     IK(2),  C(5),  C(6),  C(7),  C(8),
     D     IK(3),  C(9),  C(10), C(11), C(12),
     E     IK(4),  C(13), C(14), C(15), C(16),
     F     IK(5),  C(17), C(18), C(19), C(20)
     G  /  17,     84,
     H     4,      1HC,   1HD,   1HI,   1HR,
     I     4,      1HC,   1HE,   1HO,   1HL,
     J     4,      1HC,   1HE,   1HO,   1HR,
     K     4,      1HC,   1HO,   1HN,   1HC,
     L     4,      1HC,   1HS,   1HU,   1HB  /
      DATA
     A     IK(6),  C(21), C(22), C(23), C(24), C(25),
     B     IK(7),  C(26), C(27), C(28), C(29), C(30),
     C     IK(8),  C(31), C(32), C(33), C(34), C(35), C(36),
     D     IK(9),  C(37), C(38), C(39), C(40), C(41), C(42),
     E     IK(10), C(43), C(44), C(45), C(46), C(47), C(48)
     F  /  5,      1HI,   1HC,   1HP,   1HL,   1HI,
     G     5,      1HI,   1HC,   1HP,   1HL,   1HO,
     H     6,      1HI,   1HU,   1HN,   1HI,   1HT,   1HI,
     I     6,      1HI,   1HU,   1HN,   1HI,   1HT,   1HL,
     J     6,      1HI,   1HU,   1HN,   1HI,   1HT,   1HO  /
      DATA
     A     IK(11), C(49), C(50), C(51), C(52), C(53), C(54),
     B     IK(12), C(55), C(56), C(57), C(58), C(59),
     C     IK(13), C(60), C(61), C(62), C(63), C(64),
     D     IK(14), C(65), C(66), C(67), C(68), C(69),
     E     IK(15), C(70), C(71), C(72), C(73), C(74),
     F     IK(16), C(75), C(76), C(77), C(78),
     G     IK(17), C(79), C(80), C(81), C(82), C(83), C(84)
     H  /  6,      1HL,   1HB,   1HR,   1HE,   1HA,   1HK,
     I     5,      1HL,   1HC,   1HO,   1HL,   1H1,
     K     5,      1HL,   1HF,   1HO,   1HR,   1HT,
     L     5,      1HL,   1HI,   1HS,   1HT,   1HI,
     M     5,      1HL,   1HI,   1HS,   1HT,   1HO,
     N     4,      1HL,   1HS,   1HU,   1HB,
     O     6,      1HL,   1H1,   1HT,   1HR,   1HI,   1HP  /
      DATA
     A     IDSDIM, ID(1), ID(2), ID(3), ID(4), ID(5), ID(6)
     B  /  6,      1,     5,     4,     6,     2,     7  /
C
C         CHECK SYNTAX
C
      CALL  TPSYNT  (ID, IDSDIM, .FALSE., LERROR)
      IF  (LERROR)  GO  TO  999
      ICB  =  ICBP1(1)
      CALL  UTRDKY  (CBUFFR, ICBP1(1), ICBP2(1), IK, IKYDIM,
     A                                           C,  ICKDIM, I)
      IF  (I .GT. IKYDIM)        GO  TO  220
      IF  (CBUFFR(ICB) .EQ. CC)  GO  TO  10
      IF  (CBUFFR(ICB) .EQ. CI)  GO  TO  20
      GO  TO  30
C
   10 CONTINUE
      IF  (ICBP1(2) .NE. ICBP2(2))  GO  TO  230
      ICB     =  ICBP1(2)
      CVALUE  =  CBUFFR(ICB)
      GO  TO  40
C
   20 CONTINUE
      CALL  UTCVCI  (CBUFFR, ICBP1(2), ICBP2(2), IVALUE, LERROR)
      IF  (LERROR)  GO  TO  240
      GO  TO  40
C
   30 CONTINUE
      CALL  UTCVCL  (CBUFFR, ICBP1(2), ICBP2(2), LVALUE, LERROR)
      IF  (LERROR)  GO  TO  250
C
   40 CONTINUE
      GO  TO  (50,  60,  70,  80,  90,  100, 110, 120,
     A         130, 140, 150, 160, 170, 180, 190, 200, 210),  I
C
C         PROCESS -CDIR-
C
   50 CONTINUE
      CDIR    =  CVALUE
      GO  TO  999
C
C         PROCESS -CEOL-
C
   60 CONTINUE
      CEOL    =  CVALUE
      GO  TO  999
C
C         PROCESS -CEOR-
C
   70 CONTINUE
      CEOR    =  CVALUE
      GO  TO  999
C
C         PROCESS -CONC-
C
   80 CONTINUE
      CONC    =  CVALUE
      GO  TO  999
C
C         PROCESS -CSUB-
C
   90 CONTINUE
      CSUB    =  CVALUE
      GO  TO  999
C
C         PROCESS -ICPLI-
C
  100 CONTINUE
      ICPLI   =  IVALUE
      GO  TO  999
C
C         PROCESS -ICPLO-
C
  110 CONTINUE
      ICPLO   =  IVALUE
      GO  TO  999
C
C         PROCESS -IUNITI-
C
  120 CONTINUE
      IUNITI  =  IVALUE
      GO  TO  999
C
C         PROCESS -IUNITL-
C
  130 CONTINUE
      IUNITL  =  IVALUE
      GO  TO  999
C
C         PROCESS -IUNITO-
C
  140 CONTINUE
      IUNITO  =  IVALUE
      GO  TO  999
C
C         PROCESS -LBREAK-
C
  150 CONTINUE
      LBREAK  =  LVALUE
      ICBADD  =  1
      IF  (LFORT)               ICBADD  =  -5
      IF  (LFORT .AND. LBREAK)  ICBADD  =  -9
      GO  TO  999
C
C         PROCESS -LCOL1-
C
  160 CONTINUE
      LCOL1   =  LVALUE
      GO  TO  999
C
C         PROCESS -LFORT-
C
  170 CONTINUE
      LFORT   =  LVALUE
      ICBADD  =  1
      IF  (LFORT)               ICBADD  =  -5
      IF  (LFORT .AND. LBREAK)  ICBADD  =  -9
      GO  TO  999
C
C         PROCESS -LISTI-
C
  180 CONTINUE
      LISTI   =  LVALUE
      GO  TO  999
C
C         PROCESS -LISTO-
C
  190 CONTINUE
      LISTO   =  LVALUE
      GO  TO  999
C
C         PROCESS -LSUB-
C
  200 CONTINUE
      LSUB    =  LVALUE
      GO  TO  999
C
C         PROCESS -L1TRIP-
C
  210 CONTINUE
      L1TRIP  =  LVALUE
      GO  TO  999
C
C         ERROR   - UNKNOWN OPTION NAME
C
  220 CONTINUE
      CALL  IOERRM  (.FALSE.,
*IF(LIBRARY)
     A 44H(39H +++++++   ILLEGAL OR MISSPELLED OPTION))
*ELSE
     A 54H(49H ********   TPOPT  - ILLEGAL OR MISSPELLED OPTION))
*ENDIF
      GO  TO  999
C
C         ERROR   - SINGLE CHARACTER EXPECTED
C
  230 CONTINUE
      CALL  IOERRM  (.FALSE.,
*IF(LIBRARY)
     A 48H(43H +++++++   OPTION REQUIRES SINGLE CHARACTER))
*ELSE
     A 58H(53H ********   TPOPT  - OPTION REQUIRES SINGLE CHARACTER))
*ENDIF
      GO  TO  999
C
C         ERROR   - INTEGER EXPECTED
C
  240 CONTINUE
      CALL  IOERRM  (.FALSE.,
*IF(LIBRARY)
     A 42H(37H +++++++   OPTION REQUIRES AN INTEGER))
*ELSE
     A 52H(47H ********   TPOPT  - OPTION REQUIRES AN INTEGER))
*ENDIF
      GO  TO  999
C
C         ERROR   - LOGICAL VALUE EXPECTED
C
  250 CONTINUE
      CALL  IOERRM  (.FALSE.,
*IF(LIBRARY)
     A 47H(42H +++++++   OPTION REQUIRES A LOGICAL VALUE))
*ELSE
     A 57H(52H ********   TPOPT  - OPTION REQUIRES A LOGICAL VALUE))
*ENDIF
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE  TPRDBL  (IK, IKYDIM, C, ICKDIM, ID, IDSDIM,
     A                                 LSCAN, LSKIP, LSUBL, LERROR)
C
C-----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     TEMPLATE PROCESSOR
C
C     PURPOSE
C     -------
C     TO READ A BLOCK OF STATEMENTS DELIMITED BY
C     DIRECTIVES OF THE FORM -NAME- AND -ENDNAME-.
C     THESE DIRECTIVES MAY BE NESTED.
C
C     PARAMETERS
C     ----------
C     IK      -I-  INDEXES OF DIRECTIVES IN ARRAY C
C     IKYDIM  -I-  DIMENSION OF IK (SHOULD BE 3)
C     C       -I-  CONTAINS DIRECTIVE NAMES. DIRECTIVE 1 IS -NAME-,
C                  2 IS -ENDNAME, AND 3 IS -END-.
C     ICKDIM  -I-  DIMENSION OF C (TOTAL NUMBER OF CHARACTERS)
C     ID      -I-  CONTAINS THE SYNTAX PATTERN FOR DIRECTIVE -NAME-
C     IDSDIM  -I-  DIMENSION OF ID
C     LSCAN   -I-  IF TRUE, EXPRESSIONS WILL BE SCANNED FOR ERRORS
C                  BUT NOT EVALUATED
C     LSKIP   -I-  IF TRUE, INPUT LINES ARE SKIPPED, NOT SAVED
C     LSUBL   -I-  IF TRUE, MACRO SUBSTITUTIONS WILL BE PERFORMED
C                  WHEN ENCOUNTERED WITHIN THE BLOCK
C     LERROR  -O-  TRUE IF AN ERROR WAS ENCOUNTERED
C
C-----------------------------------------------------------------------
*INCLUDE(GLCOM)
*INCLUDE(IOCOM)
*INCLUDE(MMCOM)
*INCLUDE(MPCOM)
*INCLUDE(TPCOM)
C
C         LOCAL VARIABLES AND PARAMETERS
C
      $(DECLAREC)         C(ICKDIM)
      INTEGER             ID(IDSDIM), IK(IKYDIM)
      LOGICAL             LERROR, LSCAN, LSKIP, LSUBL
C
      INEST  =  1
C
   10 CONTINUE
          IF  (LSKIP)  ICBEOL  =  0
          CALL  MPLINE   (LSUBL)
          CALL  TPCHKD
          IF  (.NOT. LDIRL)  GO  TO  10
          CALL  UTRDKY  (CBUFFR, ICB1, ICB2, IK, IKYDIM, C, ICKDIM, I)
      GO  TO  (20,  30,  40,  10),  I
C
C         A -NAME- DIRECTIVE HAS BEEN ENCOUNTERED
C
   20 CONTINUE
      IF  (LSCAN)  CALL  TPSYNT  (ID, IDSDIM, LSCAN, LERROR)
      IF  (LSCAN .AND. (IARGS .GE. 2))  GO  TO  10
      INEST  =  INEST + 1
      GO  TO  10
C
C         AN -ENDNAME- DIRECTIVE HAS BEEN ENCOUNTERED
C
   30 CONTINUE
      INEST  =  INEST - 1
      IF  (INEST .GT. 0)  GO  TO  10
      GO  TO  999
C
C         AN -END- DIRECTIVE HAS POSSIBLY BEEN ENCOUNTERED
C
   40 CONTINUE
      LEND  =  ICB1 .GT. ICB2
      IF  (.NOT. LEND)  GO  TO  10
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE  TPRSET
C
C-----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     TEMPLATE PROCESSOR
C
C     PURPOSE
C     -------
C     TO PROCESS RESET DIRECTIVES
C
C-----------------------------------------------------------------------
*INCLUDE(GLCOM)
*INCLUDE(IOCOM)
*INCLUDE(MMCOM)
*INCLUDE(MPCOM)
*INCLUDE(TPCOM)
C
C         LOCAL VARIABLES AND PARAMETERS
C
      INTEGER             ID(4)
      LOGICAL             LERROR, LFOUND
      DATA                IDSDIM, ID(1), ID(2), ID(3), ID(4)
     A                 /  4,      1,     5,     2,     7  /
C
C         CHECK SYNTAX
C
      CALL  TPSYNT  (ID, IDSDIM, .FALSE., LERROR)
      IF  (LERROR)  GO  TO  999
      ICP1    =  ICBEND + 1
      CALL  UTBLDN  (CDIV, CBUFFR, ICBP1(1), ICBP2(1), 1,
     A               CBUFFR, ICP1, ICP2, ICBDIM, LERROR)
      ICBEND  =  ICP2
      CALL  MMPUTP  (CBUFFR, ICBP1(1), ICBP2(1),
     A               CBUFFR, ICP1, ICP2, LFOUND)
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE  TPSET
C
C-----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     TEMPLATE PROCESSOR
C
C     PURPOSE
C     -------
C     TO PROCESS SET DIRECTIVES
C
C-----------------------------------------------------------------------
*INCLUDE(GLCOM)
*INCLUDE(IOCOM)
*INCLUDE(MMCOM)
*INCLUDE(MPCOM)
*INCLUDE(TPCOM)
C
C         LOCAL VARIABLES AND PARAMETERS
C
      $(DECLAREC)         C(12)
      INTEGER             ID(8), IK(3)
      LOGICAL             LERROR
      DATA
     A     IKYDIM, ICKDIM,
     B     IK(1),  C(1),  C(2),  C(3),
     C     IK(2),  C(4),  C(5),  C(6),  C(7),  C(8),  C(9),
     D     IK(3),  C(10), C(11), C(12)
     E  /  3,      12,
     F     3,      1HS,   1HE,   1HT,
     G     6,      1HE,   1HN,   1HD,   1HS,   1HE,   1HT,
     H     3,      1HE,   1HN,   1HD  /
      DATA
     A     IDSDIM,
     B     ID(1), ID(2), ID(3), ID(4), ID(5), ID(6), ID(7), ID(8)
     C  /  8,
     D     -1,    8,     5,     -4,    7,     6,     2,     7  /
C
C         CHECK SYNTAX
C
      CALL  TPSYNT  (ID, IDSDIM, .FALSE., LERROR)
      IF  (LERROR)  GO  TO  999
      IF  (IARGS .EQ. 2)  GO  TO  20
      IF  (IARGS .EQ. 1)  GO  TO  10
      CALL  TPSETM
      IF  (LEND)  GO  TO  30
      GO  TO  999
C
C         PROCESS A MULTI-LINE SET STATEMENT
C
   10 CONTINUE
      ICBP1(2)  =  ICBEOL + 1
      CALL  TPRDBL  (IK, IKYDIM, C, ICKDIM, ID, IDSDIM,
     A                           .TRUE., .FALSE., .TRUE., LERROR)
      IF  (LEND)    GO  TO  30
      IF  (LERROR)  GO  TO  999
      ICBP2(2)  =  ICB0 - 1
C
C         SET THE VALUE
C
   20 CONTINUE
      CALL  MMPUTV  (CBUFFR, ICBP1(1), ICBP2(1),
     A               CBUFFR, ICBP1(2), ICBP2(2))
      GO  TO  999
C
   30 CONTINUE
      CALL  IOERRM  (.FALSE.,
*IF(LIBRARY)
     A 42H(37H +++++++   SET HAS NO MATCHING ENDSET))
*ELSE
     A 52H(47H ********   TPSET  - SET HAS NO MATCHING ENDSET))
*ENDIF
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE  TPSETM
C
C-----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     TEMPLATE PROCESSOR
C
C     PURPOSE
C     -------
C     TO PROCESS MULTILINE SET DIRECTIVES
C
C-----------------------------------------------------------------------
*INCLUDE(GLCOM)
*INCLUDE(IOCOM)
*INCLUDE(MMCOM)
*INCLUDE(MPCOM)
*INCLUDE(TPCOM)
C
C         LOCAL VARIABLES AND PARAMETERS
C
      $(DECLAREC)         C(9)
      INTEGER             ID(5), IK(2)
      LOGICAL             LERROR, LSKIP
      DATA
     A     IKYDIM, ICKDIM,
     B     IK(1),  C(1),  C(2),  C(3),  C(4),  C(5),  C(6),
     C     IK(2),  C(7),  C(8),  C(9)
     D  /  2,      9,
     E     6,      1HE,   1HN,   1HD,   1HS,   1HE,   1HT,
     F     3,      1HE,   1HN,   1HD  /
      DATA                IDSDIM, ID(1), ID(2), ID(3), ID(4), ID(5)
     A                 /  5,      5,     4,     -6,    5,     7  /
C
      LSKIP  =  .TRUE.
C
   10 CONTINUE
          IF  (LSKIP)  ICBEOL  =  0
          CALL  MPLINE   (.TRUE.)
          CALL  TPCHKD
          IF  (.NOT. LDIRL)     GO  TO  20
          IF  (ICB1 .GT. ICB2)  GO  TO  30
          CALL  UTRDKY  (CBUFFR, ICB1, ICB2, IK, IKYDIM, C, ICKDIM, I)
          IF  (I .EQ. 1)  GO  TO  50
          IF  (I .EQ. 2)  GO  TO  60
      IF  (I .EQ. 3)  GO  TO  10
C
C         A TEXT LINE HAS BEEN ENCOUNTERED
C
   20 CONTINUE
      IF  (.NOT. LSKIP)  GO  TO  10
      CALL  TPSYNT  (ID, IDSDIM, .FALSE., LERROR)
      IF  (LERROR)  GO  TO  10
      IF  (IARGS .EQ. 2)  GO  TO  40
      ICBEOL  =  ICBP2(1)
      LSKIP   =  .FALSE.
      GO  TO  10
C
C         A DIRECTIVE PREFIX CHARACTER HAS BEEN
C         ENCOUNTERED ON A LINE BY ITSELF
C
   30 CONTINUE
      IF  (LSKIP)  GO  TO  10
      ICBP1(2)  =  ICBP2(1) + 1
      ICBP2(2)  =  ICB0 - 1
      LSKIP     =  .TRUE.
C
C         SAVE THE VALUE
C
   40 CONTINUE
      CALL  MMPUTV  (CBUFFR, ICBP1(1), ICBP2(1),
     A               CBUFFR, ICBP1(2), ICBP2(2))
      GO  TO  10
C
C         AN ENDSET DIRECTIVE HAS BEEN ENCOUNTERED
C
   50 CONTINUE
      IF  (.NOT. LSKIP)  GO  TO  10
      GO  TO  999
C
C         AN -END- DIRECTIVE HAS POSSIBLY BEEN ENCOUNTERED
C
   60 CONTINUE
      LEND  =  ICB1 .GT. ICB2
      IF  (.NOT. LEND)  GO  TO  10
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE  TPSYNT  (IDSYNT, IDSDIM, LSCAN, LERROR)
C
C-----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     TEMPLATE PROCESSOR
C
C     PURPOSE
C     -------
C     TO CHECK A DIRECTIVE LINE FOR CORRECT SYNTAX
C
C     PARAMETERS
C     ----------
C     IDSYNT  -I-  CONTAINS THE DIRECTIVE SYNTAX PATTERN.
C                  THE VECTOR IDSYNT DESCRIBES THE TOKENS THAT
C                  ARE ALLOWED.  POSSIBLE VALUES OF IDSYNT(I):
C                          ABS(IDSYNT(I))     TOKEN
C                          --------------     -----
C                                1              (
C                                2              )
C                                3              ,
C                                4              =
C                                5              ID
C                                6              EXP
C                                7              EOL
C                                8              EOL
C                  WHEN IDSYNT(I) < 0, TWO THINGS CAN HAPPEN:
C                    - IF ABS(IDSYNT(I)) 'MATCHES' CURRENT TOKEN,
C                       SKIP TO IDSYNT(I+2) FOR NEXT MATCH.
C                    - IF NOT, SKIP TO IDSYNT(IDSYNT(I+1))
C                      FOR NEXT MATCH.
C
C     IDSDIM  -I-  DIMENSION OF IDSYNT
C     LSCAN   -I-  IF TRUE, DIRECTIVES ARE TO BE SCANNED
C                  BUT NOT EXECUTED
C     LERROR  -O-  TRUE IF THE DIRECTIVE HAS A SYNTAX ERROR
C
C-----------------------------------------------------------------------
*INCLUDE(GLCOM)
*INCLUDE(IOCOM)
*INCLUDE(MMCOM)
*INCLUDE(MPCOM)
*INCLUDE(TPCOM)
C
C         LOCAL VARIABLES AND PARAMETERS
C
      $(DECLAREC)         C(4)
      INTEGER             IDSYNT(IDSDIM)
      LOGICAL             L, LEOL, LERROR, LSCAN
      DATA                C(1), C(2), C(3), C(4)
     A                 /  1H(,  1H),  1H,,  1H=   /
C
      I       =  1
      IARGS   =  0
      LERROR  =  .FALSE.
C
C         DETERMINE WHICH TOKEN TO CHECK FOR
C
   10 CONTINUE
      ICV1    =  ICB1
      CALL  UTRDBL  (CBUFFR, ICB1, ICB2, LEOL)
      IJUMP   =  IABS(IDSYNT(I))
      GO  TO  (20, 20, 20, 20, 30, 40, 50, 50),  IJUMP
C
C         CHECK FOR DELIMITERS AND SEPARATERS
C
   20 CONTINUE
      IF  (LEOL)  GO  TO  80
      IF  (C(IJUMP) .NE. CBUFFR(ICB1))  GO  TO  80
      ICB1    =  ICB1 + 1
      GO  TO  70
C
C         CHECK FOR A NAME
C
   30 CONTINUE
      IF  (LEOL)  GO  TO  80
      CALL  UTRDNA  (CBUFFR, ICB1, ICB2, ICV1, ICV2, L)
      IF  (L)     GO  TO  80
      GO  TO  60
C
C         CHECK FOR AN EXPRESSION
C
   40 CONTINUE
      IF  (LEOL)  GO  TO  80
      CALL  TPEXPR  (ICV1, ICV2, LSCAN, L)
      IF  (L)     GO  TO  80
      GO  TO  60
C
C         CHECK FOR END OF LINE
C
   50 CONTINUE
      IF  (LEOL)  GO  TO  999
      IF  (IJUMP .NE. 8)  GO  TO  80
      ICV2  =  ICBEOL
C
   60 CONTINUE
      IARGS  =  IARGS + 1
      IF  (LSCAN)  GO  TO  70
      ICBP1(IARGS)  =  ICV1
      ICBP2(IARGS)  =  ICV2
C
   70 CONTINUE
      IF  (IDSYNT(I) .LT. 0)  I  =  I + 1
      I   =  I + 1
      IF  (I .LE. IDSDIM)  GO  TO  10
      GO  TO  999
C
C         IF THERE IS AN ALTERNATE SYNTAX FOR THIS STATEMENT
C         THEN TRY IT, OTHERWISE PRINT AN ERROR MESSAGE
C
   80 CONTINUE
      IF  (IDSYNT(I).GT. 0)  GO  TO  90
      I  =  IDSYNT(I+1)
      IF  (I .LE. IDSDIM)  GO  TO  10
C
C         ERROR EXITS
C
   90 CONTINUE
      LERROR  =  .TRUE.
      GO  TO  (100, 110, 120, 130, 140, 150, 160, 160), IJUMP
C
  100 CONTINUE
      CALL  IOERRM  (.FALSE.,
*IF(LIBRARY)
     A 41H(36H +++++++   LEFT PARENTHESIS EXPECTED))
*ELSE
     A 51H(46H ********   TPSYNT - LEFT PARENTHESIS EXPECTED))
*ENDIF
      GO  TO  999
C
  110 CONTINUE
      CALL  IOERRM  (.FALSE.,
*IF(LIBRARY)
     A 42H(37H +++++++   RIGHT PARENTHESIS EXPECTED))
*ELSE
     A 52H(47H ********   TPSYNT - RIGHT PARENTHESIS EXPECTED))
*ENDIF
      GO  TO  999
C
  120 CONTINUE
      CALL  IOERRM  (.FALSE.,
*IF(LIBRARY)
     A 30H(25H +++++++   COMMA EXPECTED))
*ELSE
     A 40H(35H ********   TPSYNT - COMMA EXPECTED))
*ENDIF
      GO  TO  999
C
  130 CONTINUE
      CALL  IOERRM  (.FALSE.,
*IF(LIBRARY)
     A 36H(31H +++++++   EQUALS SIGN EXPECTED))
*ELSE
     A 46H(41H ********   TPSYNT - EQUALS SIGN EXPECTED))
*ENDIF
      GO  TO  999
C
  140 CONTINUE
      CALL  IOERRM  (.FALSE.,
*IF(LIBRARY)
     A 33H(28H +++++++   VARIABLE EXPECTED))
*ELSE
     A 43H(38H ********   TPSYNT - VARIABLE EXPECTED))
*ENDIF
      GO  TO  999
C
  150 CONTINUE
      CALL  IOERRM  (.FALSE.,
*IF(LIBRARY)
     A 50H(45H +++++++   MISSING OR UNRECOGNIZED EXPRESSION))
*ELSE
     A 60H(55H ********   TPSYNT - MISSING OR UNRECOGNIZED EXPRESSION))
*ENDIF
      GO  TO  999
C
  160 CONTINUE
      CALL  IOERRM  (.FALSE.,
*IF(LIBRARY)
     A 49H(44H +++++++   ILLEGAL CHARACTERS AT END OF LINE))
*ELSE
     A 59H(54H ********   TPSYNT - ILLEGAL CHARACTERS AT END OF LINE))
*ENDIF
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE  UTBLDN  (CPREFX, CROOT, ICR1, ICR2, ISUFFX,
     A                     CNAME, ICN1, ICN2, ICNDIM, LERROR)
C
C-----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     UTILITY
C
C     PURPOSE
C     -------
C     TO BUILD A NAME GIVEN A PREFIX, ROOT, AND SUFFIX
C
C     PARAMETERS
C     ----------
C     CPREFX  -I-  A ONE CHARACTER PREFIX
C     CROOT   -I-  ROOT OF THE NAME
C     ICR1    -I-  INDEX OF THE FIRST CHARACTER IN THE ROOT
C     ICR2    -I-  INDEX OF THE LAST CHARACTER IN THE ROOT
C     ISUFFX  -I-  INTEGER SUFFIX
C     CNAME   -O-  THE NAME
C     ICN1    -I-  INDEX OF THE FIRST CHARACTER IN THE NAME
C     ICN2    -O-  INDEX OF THE LAST CHARACTER IN THE NAME
C     ICNDIM  -I-  DIMENSION OF CNAME
C     LERROR  -O-  TRUE IF AN ERROR OCCURED
C
C-----------------------------------------------------------------------
*INCLUDE(GLCOM)
C
C         LOCAL VARIABLES AND PARAMETERS
C
      $(DECLAREC)         CNAME(ICNDIM), CPREFX, CROOT(ICR2)
      LOGICAL             LERROR
C
      LERROR       =  ICN1 + ICR2 - ICR1 + 1 .GT. ICNDIM
      IF  (LERROR)  GO  TO  999
      ICN2         =  ICN1
      CNAME(ICN2)  =  CPREFX
      IF  (ICR1 .GT. ICR2)  GO  TO  20
      DO  10  I=ICR1,ICR2
          ICN2         =  ICN2 + 1
          CNAME(ICN2)  =  CROOT(I)
   10 CONTINUE
   20 CONTINUE
      IF  (ISUFFX .LT. 0)  GO  TO  999
      I           =  ICN2 + 1
      CALL  UTCVIC  (CNAME, I, ICN2, ICNDIM, ISUFFX, LERROR)
C
  999 CONTINUE
      RETURN
      END
*IF(TESTCH)
*ELSE
      SUBROUTINE  UTCHKA  (C, LALPHA)
C
C-----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     UTILITY
C
C     PURPOSE
C     -------
C     TO CHECK TO SEE IF A CHARACTER IS ALPHABETIC.
C     THIS ROUTINE MAY HAVE TO BE MODIFIED FOR SOME CHARACTER SETS.
C     IN A FORTRAN 77 SETTING THE INTRINSIC LLE MAY BE USEFUL.
C
C     PARAMETERS
C     ----------
C     C       -I-  THE CHARACTER TO BE TESTED
C     LALPHA  -O-  TRUE IF THE CHARACTER IS ALPHABETIC
C
C-----------------------------------------------------------------------
*INCLUDE(GLCOM)
C
C         LOCAL VARIABLES AND PARAMETERS
C
      $(DECLAREC)         C
      LOGICAL             LALPHA
C
      LALPHA  =  (CA .LE. C)  .AND.  (C .LE. CZ)
C
      RETURN
      END
*ENDIF
*IF(TESTCH)
*ELSE
      SUBROUTINE  UTCHKN  (C, LNUMER)
C
C-----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     UTILITY
C
C     PURPOSE
C     -------
C     TO CHECK TO SEE IF A CHARACTER IS NUMERIC
C     THIS ROUTINE MAY HAVE TO BE MODIFIED FOR SOME CHARACTER SETS.
C
C     PARAMETERS
C     ----------
C     C       -I-  CHARACTER TO BE TESTED
C     LNUMER  -O-  TRUE IF THE CHARACTER IS NUMERIC
C
C-----------------------------------------------------------------------
*INCLUDE(GLCOM)
C
C         LOCAL VARIABLES AND PARAMETERS
C
      $(DECLAREC)         C
      LOGICAL             LNUMER
C
      LNUMER  =  (C0 .LE. C)  .AND.  (C .LE. C9)
C
      RETURN
      END
*ENDIF
*IF(TESTCH)
*ELSE
      SUBROUTINE  UTCHKS  (C, LSPECL)
C
C-----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     UTILITY
C
C     PURPOSE
C     -------
C     TO CHECK TO SEE IF A CHARACTER IS A SPECIAL CHARACTER,
C     I.E. NOT ALPHABETIC OR NUMERIC
C     THIS ROUTINE MAY HAVE TO BE MODIFIED FOR SOME CHARACTER SETS.
C
C     PARAMETERS
C     ----------
C     C       -I-  CHARACTER TO BE TESTED
C     LSPECL  -O-  TRUE IF THE CHARACTER IS A SPECIAL CHARACTER
C
C-----------------------------------------------------------------------
*INCLUDE(GLCOM)
C
C         LOCAL VARIABLES AND PARAMETERS
C
      $(DECLAREC)         C
      LOGICAL             LSPECL
C
      LSPECL  =  .NOT.  (((CA .LE. C)  .AND.  (C .LE. CZ))  .OR.
     A                   ((C0 .LE. C)  .AND.  (C .LE. C9)))
C
      RETURN
      END
*ENDIF
      SUBROUTINE  UTCVCI  (CLINE, ICL1, ICL2, IVALUE, LERROR)
C
C-----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     UTILITY
C
C     PURPOSE
C     -------
C     TO CONVERT A CHARACTER STRING INTO AN INTEGER
C
C     PARAMETERS
C     ----------
C     CLINE   -I-  STRING TO BE CONVERTED
C     ICL1    -I-  INDEX OF THE FIRST CHARACTER IN THE STRING
C     ICL2    -I-  INDEX OF THE LAST CHARACTER IN THE STRING
C     IVALUE  -O-  INTEGER RESULT
C     LERROR  -O-  TRUE IF AN ERROR OCCURED
C
C-----------------------------------------------------------------------
*INCLUDE(GLCOM)
C
C         LOCAL VARIABLES AND PARAMETERS
C
      $(DECLAREC)         C(10), CLINE(ICL2), CLINEI
      LOGICAL             LERROR, LMINUS
      DATA                C(1),  C(2),  C(3),  C(4),  C(5),
     A                    C(6),  C(7),  C(8),  C(9),  C(10)
     B                 /  1H0,   1H1,   1H2,   1H3,   1H4,
     C                    1H5,   1H6,   1H7,   1H8,   1H9  /
C
      IVALUE  =  0
      I       =  ICL1
      CALL  UTRDBL  (CLINE, I, ICL2, LERROR)
      IF  (LERROR)  GO  TO  999
      LMINUS  =  CLINE(I) .EQ. CMINUS
      IF  ((.NOT. LMINUS) .AND. (CLINE(I) .NE. CPLUS))  GO  TO  10
          I  =  I + 1
          CALL  UTRDBL  (CLINE, I, ICL2, LERROR)
          IF  (LERROR)  GO  TO  999
C
   10 CONTINUE
      I1  =  I
      DO  40  I=I1,ICL2
          CLINEI  =  CLINE(I)
          DO  20  IC=1,10
              IF  (CLINEI .EQ. C(IC))  GO  TO  30
   20     CONTINUE
          IF  (I .GT. I1)  GO  TO  50
          GO  TO  999
   30     CONTINUE
          IVALUE  =  IVALUE*10 + IC - 1
   40 CONTINUE
C
   50 CONTINUE
      LERROR  =  .FALSE.
      IF  (LMINUS)  IVALUE  =  -IVALUE
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE  UTCVCL  (CLINE, ICL1, ICL2, LVALUE, LERROR)
C
C-----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     UTILITY
C
C     PURPOSE
C     -------
C     TO CONVERT A CHARACTER STRING TO A LOGICAL VALUE
C
C     PARAMETERS
C     ----------
C     CLINE   -I-  STRING TO BE CONVERTED
C     ICL1    -I-  INDEX OF THE FIRST CHARACTER IN THE STRING
C     ICL2    -I-  INDEX OF THE LAST CHARACTER IN THE STRING
C     LVALUE  -O-  THE LOGICAL RESULT
C     LERROR  -I-  TRUE IF AN ERROR OCCURED
C
C-----------------------------------------------------------------------
*INCLUDE(GLCOM)
C
C         LOCAL VARIABLES AND PARAMETERS
C
      $(DECLAREC)         C(13), CLINE(ICL2)
      INTEGER             IK(2)
      LOGICAL             LERROR, LV(3), LVALUE
      DATA
     A     IKYDIM, ICKDIM,
     B     IK(1),  C(1),  C(2),  C(3),  C(4),  C(5),  C(6),
     C     IK(2),  C(7),  C(8),  C(9),  C(10), C(11), C(12), C(13)
     D  /  6,      13,
     E     6,      1H.,   1HT,   1HR,   1HU,   1HE,   1H.,
     F     7,      1H.,   1HF,   1HA,   1HL,   1HS,   1HE,   1H.  /
      DATA
     A     LV(1),   LV(2),   LV(3)
     B  /  .TRUE.,  .FALSE., .TRUE.  /
C
      LERROR  =  .TRUE.
      IF  (ICL1 .GT. ICL2)  GO  TO  999
      DO  10  I=ICL1,ICL2
          IF  (CLINE(I) .NE. CBLANK)  GO  TO  20
   10 CONTINUE
      GO  TO  999
C
   20 CONTINUE
      CALL  UTRDKY  (CLINE, ICL1, ICL2, IK, IKYDIM, C, ICKDIM, I)
      LERROR  =  I .GT. IKYDIM
      LVALUE  =  LV(I)
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE  UTCVIC  (CLINE, ICL1, ICL2, ICLDIM, IVALUE, LERROR)
C
C-----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     UTILITY
C
C     PURPOSE
C     -------
C     TO CONVERT AN INTEGER INTO A CHARACTER STRING
C
C     PARAMETERS
C     ----------
C     CLINE   -O-  STRING RESULT
C     ICL1    -I-  INDEX OF THE FIRST CHARACTER IN THE STRING
C     ICL2    -O-  INDEX OF THE LAST CHARACTER IN THE STRING
C     ICLDIM  -I-  DIMENSION OF CLINE
C     IVALUE  -I-  INTEGER TO BE CONVERTED
C     LERROR  -O-  TRUE IF AN ERROR OCCURED
C
C-----------------------------------------------------------------------
*INCLUDE(GLCOM)
C
C         LOCAL VARIABLES AND PARAMETERS
C
      $(DECLAREC)         C(10), CTEMP, CLINE(ICLDIM)
      LOGICAL             LERROR
      DATA                C(1),  C(2),  C(3),  C(4),  C(5),
     A                    C(6),  C(7),  C(8),  C(9),  C(10)
     B                 /  1H0,   1H1,   1H2,   1H3,   1H4,
     C                    1H5,   1H6,   1H7,   1H8,   1H9  /
C
      I1      =  IABS(IVALUE)
      LERROR  =  .TRUE.
      ICL2     =  ICL1 - 1
C
C         CONVERT AND THEN REMOVE THE LEAST SIGNIFICANT DIGITS FIRST
C
   10 CONTINUE
          I2          =  I1
          I1          =  I1 / 10
          I2          =  I2 - I1*10
          ICL2         =  ICL2 + 1
          IF  (ICL2 .GT. ICLDIM)  GO  TO  999
          CLINE(ICL2)  =  C(I2+1)
      IF  (I1 .GT. 0)  GO  TO  10
C
C         IF NECESSARY, ADD THE MINUS SIGN
C
      IF  (IVALUE .GE. 0)  GO  TO  20
          ICL2         =  ICL2 + 1
          IF  (ICL2 .GT. ICLDIM)  GO  TO  999
          CLINE(ICL2)  =  CMINUS
C
C         REVERSE THE STRING TO PUT THE DIGITS IN THE PROPER ORDER
C
   20 CONTINUE
      LERROR  =  .FALSE.
      IF  (ICL1 .GE. ICL2)  GO  TO  999
      ICL2MD  =  (ICL1 + ICL2 - 1) / 2
      I2      =  ICL2
      DO  30  I1=ICL1,ICL2MD
          CTEMP      =  CLINE(I1)
          CLINE(I1)  =  CLINE(I2)
          CLINE(I2)  =  CTEMP
          I2         =  I2 - 1
   30 CONTINUE
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE  UTCVLC  (CLINE, ICL1, ICL2, ICLDIM, LVALUE, LERROR)
C
C-----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     UTILITY
C
C     PURPOSE
C     -------
C     TO CONVERT A LOGICAL VALUE TO A CHARACTER
C
C     PARAMETERS
C     ----------
C     CLINE   -O-  STRING RESULT
C     ICL1    -I-  INDEX OF THE FIRST CHARACTER IN THE STRING
C     ICL2    -O-  INDEX OF THE LAST CHARACTER IN THE STRING
C     ICLDIM  -I-  DIMENSION OF CLINE
C     LVALUE  -I-  LOGICAL VALUE TO BE CONVERTED
C     LERROR  -O-  TRUE IF AN ERROR OCCURED
C
C-----------------------------------------------------------------------
*INCLUDE(GLCOM)
C
C         LOCAL VARIABLES AND PARAMETERS
C
      $(DECLAREC)         CF(7), CLINE(ICLDIM), CT(6)
      LOGICAL             LERROR, LVALUE
      DATA
     A     ICFDIM,CF(1),  CF(2),  CF(3),  CF(4),  CF(5),  CF(6),  CF(7),
     B     ICTDIM,CT(1),  CT(2),  CT(3),  CT(4),  CT(5),  CT(6)
     C  /  7,     1H.,    1HF,    1HA,    1HL,    1HS,    1HE,    1H.,
     D     6,     1H.,    1HT,    1HR,    1HU,    1HE,    1H.  /
C
      ICL2    =  ICL1 - 1
      IF  (LVALUE)  GO  TO  20
      LERROR  =  (ICL2 + ICFDIM) .GT. ICLDIM
      IF  (LERROR)  GO  TO  999
      DO  10  I=1,ICFDIM
          ICL2         =  ICL2 + 1
          CLINE(ICL2)  =  CF(I)
   10 CONTINUE
      GO  TO  999
C
   20 CONTINUE
      LERROR  =  (ICL2 + ICTDIM) .GT. ICLDIM
      IF  (LERROR)  GO  TO  999
      DO  30  I=1,ICTDIM
          ICL2         =  ICL2 + 1
          CLINE(ICL2)  =  CT(I)
   30 CONTINUE
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE  UTCVNI  (CNAME, ICN1, ICN2, INAME, LERROR)
C-----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     UTILITY
C
C     PURPOSE
C     -------
C     TO CONVERT (HASH) A NAME INTO AN INTEGER
C
C     PARAMETERS
C     ----------
C     CNAME   -I-  THE NAME TO BE HASHED
C     ICN1    -I-  INDEX OF THE FIRST CHARACTER IN THE NAME
C     ICN2    -I-  INDEX OF THE LAST CHARACTER IN THE NAME
C     INAME   -O-  INTEGER RESULT
C     LERROR  -O-  TRUE IF AN ERROR OCCURED
C
C-----------------------------------------------------------------------
*INCLUDE(GLCOM)
C
C         LOCAL VARIABLES AND PARAMETERS
C
*IF(CDC)
      $(DECLAREC)         CNAME(ICN2)
      LOGICAL             LERROR
      DATA                ICIDIM  /  6  /
*ELSE
      INTEGER             IC(6)
      LOGICAL             LERROR
*IF(CSTAR1)
      CHARACTER*1         CNAME(ICN2)
*ELSE
      INTEGER             C(48), CNAME(ICN2), CNAMEI
      DATA
     A              ICHDIM,
     B              C(1),   C(2),   C(3),   C(4),   C(5),   C(6),
     C              C(7),   C(8),   C(9),   C(10),  C(11),  C(12),
     D              C(13),  C(14),  C(15),  C(16),  C(17),  C(18),
     E              C(19),  C(20),  C(21),  C(22),  C(23),  C(24),
     F              C(25),  C(26),  C(27),  C(28),  C(29),  C(30),
     G              C(31),  C(32),  C(33),  C(34),  C(35),  C(36),
     H              C(37),  C(38),  C(39),  C(40),  C(41),  C(42),
     I              C(43),  C(44),  C(45),  C(46),  C(47),  C(48)
     J           /  48,
     K              1HA,    1HB,    1HC,    1HD,    1HE,    1HF,
     L              1HG,    1HH,    1HI,    1HJ,    1HK,    1HL,
     M              1HM,    1HN,    1HO,    1HP,    1HQ,    1HR,
     N              1HS,    1HT,    1HU,    1HV,    1HW,    1HX,
     O              1HY,    1HZ,    1H0,    1H1,    1H2,    1H3,
     P              1H4,    1H5,    1H6,    1H7,    1H8,    1H9,
     Q              1H+,    1H-,    1H*,    1H,,    1H=,    1H(,
*OPTION(LSUB=.FALSE.)
     R              1H),    1H.,    1H,,    1H',    1H$,    1H  /
*OPTION(LSUB=.TRUE.)
*ENDIF
      DATA
     A              ICIDIM,
     B              IC(1),  IC(2),  IC(3),  IC(4),  IC(5),  IC(6)
     C           /  6,
     D              61,     1,      47,     61,     1,      47  /
*ENDIF
C
      LERROR  =  ICN1 .GT. ICN2
      IF  (LERROR)  GO  TO  999
      I       =  0
      INAME   =  0
      ICNMIN  =  MIN0(ICN2, ICN1+ICIDIM-1)
C
*IF(CDC)
*IF(CSTAR1)
      DO  10  ICN=ICN1,ICNMIN
          INAME  =  INAME .OR. SHIFT(ICHAR(CNAME(ICN)), I)
          I      =  I + 6
   10 CONTINUE
*ELSE
      DO  10  ICN=ICN1,ICNMIN
          I      =  I + 6
          INAME  =  INAME .OR.
     A              SHIFT(CNAME(ICN).AND.77000000000000000000B, I)
   10 CONTINUE
*ENDIF
*ELSE
*IF (CSTAR1)
      DO  10  ICN=ICN1,ICNMIN
          I       =  I + 1
          INAME   =  INAME + IC(I)*ICHAR( CNAME(ICN) )
   10 CONTINUE
*ELSE
      DO  30  ICN=ICN1,ICNMIN
          CNAMEI  =  CNAME(ICN)
          DO  10  ICH=1,ICHDIM
              IF  (CNAMEI .EQ. C(ICH))  GO  TO  20
   10     CONTINUE
          ICH     =  ICHDIM + 1
   20     CONTINUE
          I       =  I + 1
          INAME   =  INAME + IC(I)*ICH
   30 CONTINUE
*ENDIF
*ENDIF
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE  UTRDBL  (CLINE, ICL1, ICL2, LEOL)
C
C-----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     UTILITY
C
C     PURPOSE
C     -------
C     TO READ (SKIP) BLANKS IN A LINE
C
C     PARAMETERS
C     ----------
C     CLINE   -I-  LINE OF CHARACTERS
C     ICL1    -I-  INDEX OF THE FIRST CHARACTER IN THE LINE
C     ICL2    -I-  INDEX OF THE LAST CHARACTER IN THE LINE
C     LEOL    -O-  TRUE IF THE END OF THE LINE WAS REACHED
C
C-----------------------------------------------------------------------
*INCLUDE(GLCOM)
C
C         LOCAL VARIABLES AND PARAMETERS
C
      $(DECLAREC)         CLINE(ICL2)
      LOGICAL             LEOL
C
      IF  (ICL1 .GT. ICL2)  GO  TO  20
C
      DO  10  I=ICL1,ICL2
          IF  (CBLANK .NE. CLINE(I))  GO  TO  30
   10 CONTINUE
C
   20 CONTINUE
      ICL1  =  ICL2 + 1
      LEOL  =  .TRUE.
      GO  TO  999
C
   30 CONTINUE
      ICL1  =  I
      LEOL  =  .FALSE.
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE  UTRDKY  (CLINE, ICL1, ICL2, IKEY, IKYDIM,
     A                                        CKEY, ICKDIM, IK)
C
C-----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     UTILITY
C
C     PURPOSE
C     -------
C     TO MATCH CHARACTERS WITH ONE OF A GIVEN SET OF KEYS
C
C     PARAMETERS
C     ----------
C     CLINE   -I-  LINE OF CHARACTERS
C     ICL1    -I-  INDEX OF THE FIRST CHARACTER IN THE LINE
C     ICL2    -I-  INDEX OF THE LAST CHARACTER IN THE LINE
C     IKEY    -I-  CONTAINS THE LENGTH OF EACH KEY
C     IKYDIM  -I-  NUMBER OF KEYS
C     CKEY    -I-  CONTAINS THE KEYS
C     CKYDIM  -I-  DIMENSION OF CKEY
C     IK      -O-  NUMBER OF THE MATCHED KEY
C
C-----------------------------------------------------------------------
*INCLUDE(GLCOM)
C
C         LOCAL VARIABLES AND PARAMETERS
C
      $(DECLAREC)         CLINE(ICL2), CKEY(ICKDIM)
      INTEGER             IKEY(IKYDIM)
C
      IF  (ICL1 .GT. ICL2)  GO  TO  30
      ICK2    =  0
      ICLDIF  =  ICL2 - ICL1 + 1
C
      DO  20  IK=1,IKYDIM
          ICK1   =  ICK2 + 1
          ICK2   =  ICK2 + IKEY(IK)
          IF  (ICLDIF .LT. IKEY(IK))  GO  TO  20
          I      =  ICL1
          DO  10  ICK=ICK1,ICK2
              IF  (CLINE(I) .NE. CKEY(ICK))   GO  TO  20
              I  =  I + 1
   10     CONTINUE
          GO  TO  40
   20 CONTINUE
C
   30 CONTINUE
      IK    =  IKYDIM + 1
      GO  TO  999
C
   40 CONTINUE
      ICL1  =  ICL1 + IKEY(IK)
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE  UTRDNA  (CLINE, ICL1, ICL2, ICL1NA, ICL2NA, LERROR)
C
C-----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     UTILITY
C
C     PURPOSE
C     -------
C     TO READ A NAME ON A LINE
C
C     PARAMETERS
C     ----------
C     CLINE   -I-  LINE OF CHARACTERS
C     ICL1    -I-  INDEX OF THE FIRST CHARACTER IN THE LINE
C     ICL2    -I-  INDEX OF THE LAST CHARACTER IN THE LINE
C     ICL1NA  -O-  INDEX OF THE FIRST CHARACTER IN THE NAME
C     ICL2NA  -O-  INDEX OF THE LAST CHARACTER IN THE NAME
C     LERROR  -O-  TRUE IF AN ERROR OCCURED
C
C-----------------------------------------------------------------------
*INCLUDE(GLCOM)
C
C         LOCAL VARIABLES AND PARAMETERS
C
      $(DECLAREC)         CLINE(ICL2)
      LOGICAL             L, LERROR
C
      LERROR  =  .TRUE.
      IF  (ICL1 .GT. ICL2)  GO  TO  999
C
      DO  10  I=ICL1,ICL2
*IF(TESTCH)
          IF  (.NOT. (((CA .LE. CLINE(I))
     A         .AND.   (CLINE(I) .LE. CZ))
     B         .OR.   ((C0 .LE. CLINE(I))
     C         .AND.   (CLINE(I) .LE. C9))))  GO  TO  20
*ELSE
          CALL  UTCHKS  (CLINE(I), L)
          IF  (L)  GO  TO  20
*ENDIF
   10 CONTINUE
C
      I       =  ICL2 + 1
C
   20 CONTINUE
*IF(TESTCH)
      IF  (.NOT. ((CA .LE. CLINE(ICL1))
     A     .AND.  (CLINE(ICL1) .LE. CZ)))  GO  TO  999
*ELSE
      CALL  UTCHKA  (CLINE(ICL1), L)
      IF  (.NOT. L)  GO  TO  999
*ENDIF
      ICL1NA   =  ICL1
      ICL1     =  I
      ICL2NA  =  I - 1
      LERROR  =  .FALSE.
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE  UTRDNU  (CLINE, ICL1, ICL2, ICL1NU, ICL2NU, LERROR)
C
C-----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     UTILITY
C
C     PURPOSE
C     -------
C     TO READ A NUMBER ON A LINE
C
C     PARAMETERS
C     ----------
C     CLINE   -I-  LINE OF CHARACTERS
C     ICL1    -I-  INDEX OF THE FIRST CHARACTER IN THE LINE
C     ICL2    -I-  INDEX OF THE LAST CHARACTER IN THE LINE
C     ICL1NU  -O-  INDEX OF THE FIRST CHARACTER IN THE NUMBER
C     ICL2NU  -O-  INDEX OF THE LAST CHARACTER IN THE NUMBER
C     LERROR  -O-  TRUE IF AN ERROR OCCURED
C
C-----------------------------------------------------------------------
*INCLUDE(GLCOM)
C
C         LOCAL VARIABLES AND PARAMETERS
C
      $(DECLAREC)         CLINE(ICL2)
      LOGICAL             L, LERROR
C
      LERROR  =  ICL1 .GT. ICL2
      IF  (LERROR)  GO  TO  999
      I       =  ICL1
      IF  ((CLINE(I) .NE. CMINUS)
     A    .AND. (CLINE(I) .NE. CPLUS))  GO  TO  10
          I   =  I + 1
          CALL  UTRDBL  (CLINE, I, ICL2, LERROR)
          IF  (LERROR)  GO  TO  999
C
   10 CONTINUE
      ICL     =  I
      DO  20  I=ICL,ICL2
*IF(TESTCH)
          IF  (.NOT. ((C0 .LE. CLINE(I))
     A         .AND.  (CLINE(I) .LE. C9)))  GO  TO  30
*ELSE
          CALL  UTCHKN  (CLINE(I), L)
          IF  (.NOT. L)  GO  TO  30
*ENDIF
   20 CONTINUE
C
      I       =  ICL2 + 1
C
   30 CONTINUE
      ICL1NU  =  ICL1
      ICL1    =  I
      ICL2NU  =  I - 1
      LERROR  =  ICL1NU .GT. ICL2NU
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE  UTRDQS  (CLINE, ICL1, ICL2, ICL1QS, ICL2QS, LERROR)
C
C-----------------------------------------------------------------------
C
C     FAMILY
C     ------
C     UTILITY
C
C     PURPOSE
C     -------
C     TO READ A QUOTED STRING ON A LINE
C
C     PARAMETERS
C     ----------
C     CLINE   -I-  LINE OF CHARACTERS
C     ICL1    -I-  INDEX OF THE FIRST CHARACTER IN THE LINE
C     ICL2    -I-  INDEX OF THE LAST CHARACTER IN THE LINE
C     ICL1NU  -O-  INDEX OF THE FIRST CHARACTER IN THE STRING
C     ICL2NU  -O-  INDEX OF THE LAST CHARACTER IN THE STRING
C     LERROR  -O-  TRUE IF AN ERROR OCCURED
C
C-----------------------------------------------------------------------
*INCLUDE(GLCOM)
C
C         LOCAL VARIABLES AND PARAMETERS
C
      $(DECLAREC)         CLINE(ICL2), CQTEMP
      LOGICAL             LERROR
C
      LERROR  =  .TRUE.
      ICL1QS  =  ICL1 + 1
      IF  (ICL1QS .GT. ICL2)  GO  TO  999
      CQTEMP  =  CLINE(ICL1)
C
      DO  10  I=ICL1QS,ICL2
          IF  (CLINE(I) .EQ. CQTEMP)  GO  TO  20
   10 CONTINUE
C
      GO  TO  999
C
   20 CONTINUE
      ICL1    =  I + 1
      ICL2QS  =  I - 1
      LERROR  =  .FALSE.
C
  999 CONTINUE
      RETURN
      END
*END
