'HEAD'  NAME LIST PROCESSING
C     EDIT DATE   11DEC78  16:29
C     SOURCE FILE NLISTFTM.FS
C     AUTHOR      F. T. MICKEY
C     CLUSTER     23
      'OUTFILE' SNMLSTFTM.FR
C     INTEGER FUNCTION SNMLST
C
C     SEARCH THE NAMELIST FOR AN ENTRY MATCHING THE CONTENTS
C     OF 'NAME';  IF FOUND, RETURN INDEX TO ENTRIES IN NLX.
C     IF NOT FOUND, RETURN INDEX OF EMPTY LIST ENTRY FOR USE
C     IN DEFINING NEW ENTRY.
C
      INTEGER FUNCTION SNMLST (DUM)
      'INCLUDE'     NLNAMEFTM.IN,
      'INCLUDE' NLISTCFTM.IN,
      'INCLUDE' NLARAYFTM.IN,
      'INCLUDE' LOGOSAJH.IN,
      INTEGER  GETTX, ENTNUM, GCHAR, NLOPS
      INTEGER  TS, DUM
      CALL SEARCH
C     SEE IF THIS IS FIRST HASH ADDRESS
      'IF' (FNLX .EQ. 0)
C        YES, SAVE IT
         FNLX = NLX
         'ENDIF'
C     IS IT A CONSTANT?
      CFLAG = IAND (NLIST (NLX), CBIT)
      'IF' (CFLAG .NE. 0 .AND. GCHAR (NAME (1), 2) .GT. 1 ^
         .AND. NLOC (NLX) .NE. -1)
C        IT MUST BE DEFINED, FLAG IT AS USED
         CALL NLSET (NLX, USEBIT)
         NLX = NLOC (NLX)
         TS = GETTX (NLX)
         'IF' (GCHAR (NTEXT (TS), 2) .LE. 3)
            NUMBER = NLOPS (CVALUE, NLX)
            NLX = ENTNUM (DUMMY)
            'ENDIF'
         'ENDIF'
      SNMLST = NLX
      RETURN
      END
      'OUTFILE' SOPLSTFTM.FR
C     INTEGER FUNCTION SOPLST
C
C     SEARCH NAME LIST FOR LOGOS OPERATOR
C
      INTEGER FUNCTION SOPLST (DUM)
      'INCLUDE' LOGOSAJH.IN,
      'INCLUDE'     NLNAMEFTM.IN,
      'INCLUDE' NLISTCFTM.IN,
      'INCLUDE' NLARAYFTM.IN,
      'INCLUDE' OPERSAJH.IN,

      INTEGER NLXTS, TS, DUM
      INTEGER GCHAR
      NLXTS = NLX
C     SET OP BIT IN NAME, THEN SEARCH NAME LIST
      TS = GCHAR (NAME, 1)
      TS = TS + OPBIT
      CALL PCHAR (NAME, 1, TS)
      'IF' (PSYMB .NE. GIZZY)
C        "ILLEGAL 'XXX' OPERATOR"
         CALL FAULTP (9)
         'ENDIF'
      CALL SEARCH
      SOPLST = NLOC (NLX)
      'IF' (SOPLST .EQ. -1)
C        NOT A DEFINED OPERATOR
         CALL FAULTP (9)
         SOPLST = COMMA
         'ENDIF'
      NLX = NLXTS
      RETURN
      END
      'OUTFILE' SLISTFTM.FR
C     SUBROUTINE SLIST
C
C     GIVEN INITIAL HASH INDEX, FIND NAME TEXT MATCH OR EMPTY ENTRY
C
      SUBROUTINE SLIST
      'INCLUDE'    NLNAMEFTM.IN,
      'INCLUDE' NLISTCFTM.IN,
      'INCLUDE' NLARAYFTM.IN,

      INTEGER     SRCHF, TS, ITS
      INTEGER     GETTX
      SRCHF = 0
C     GET NAME TEXT INDEX FOR THIS ENTRY
1     TS = GETTX (NLX)
      'IF' (TS .NE. 0)
C        COMPARE TARGET NAME TO NAME TEXT
         'DOLOOP' ITS = 1, NLWRDS
            'IF' (NTEXT (TS) .NE. NAME (ITS))
C              NO MATCH, NEXT ENTRY
               NLX = NLX + 1
               'IF' (NLX .LT. NLSTOP)
C                 STILL BELOW TOP OF NAMELIST
                  IF (SRCHF .EQ. 0 .OR. NLX .LT. SRCHST) GO TO 1
C
                  CALL FATAL (19)
                  'ELSE'
C                 TOP OF NAME LIST, START AGAIN FROM BOTTOM
                  SRCHF = SRCHF + 1
                  NLX = NLSTRT
                  GO TO 1
                  'ENDIF'
               'ELSE'
C              MATCH SO FAR, KEEP COMPARING NAMES
               TS = TS + 1
               'ENDIF'
            'END'
         'ENDIF'
C     NAME MATCH, RETURN INDEX IN NLX
      RETURN
      END
      'OUTFILE' SEARCHFTM.FR
C     SUBROUTINE SEARCH
C
C     CALCULATE INITIAL HASH INDEX, THEN CALL SLIST;
C     IF NAME NOT DEFINED, ENTER IT IN EMPTY SLOT
C     RETURNED BY SLIST.
C
      SUBROUTINE SEARCH
      'INCLUDE'    NLNAMEFTM.IN,
      'INCLUDE' NLISTCFTM.IN,
      'INCLUDE' NLARAYFTM.IN,
      'INCLUDE' LOGOSAJH.IN,
      INTEGER ITS, KTS, NTEMP
      INTEGER GCHAR, MODTXT, CLOCN
      LOGICAL     NLTEST
      ITS = I
      KTS = K
      NTEMP = GCHAR (NAME, 1)
      'IF' ((PARFLG .NE. 0 .OR. SPARFL .NE. 0) ^
         .AND. IAND (OPBIT, NTEMP) .EQ. 0)
C        NOT IDENTIFIED AS PARAMETER OR OPERATOR, CHECK FOR
C        LOCAL PARAMETER DEFINITION FIRST
         NTEMP = NTEMP + PARBIT
         CALL PCHAR (NAME, 1, NTEMP)
         'ENDIF'
      NLWRDS = ISHFT (IAND (NTEMP, 31), -1) + 1
      'DO'
C        CALCULATE HASH ADDRESS
         NLX = 0
         'DOLOOP' I = 1, NLWRDS
            NLX = NLX + IAND (NAME (I), 16191)   // = 03F3F
            'END'
         NLX = IAND (ISHFT (NLX, -8) + ISHFT (NLX, 8), 32767)
         NLX = MOD (NLX, NLSIZE) + 1
         SRCHST = NLX
         CALL SLIST
         'IF' (NTEXTX (NLX) .EQ. 0)
C           NOT IN NAMELIST YET, ENTER IT
            'WHILE' (SPARFL .NE. 0 .AND. IAND (NTEMP, PARBIT) .NE. 0)
C              LOCAL NAME NOT FOUND, TRY GLOBAL NAME
               NTEMP = NTEMP - PARBIT
               CALL PCHAR (NAME, 1, NTEMP)
               'END'
         NTEXTX (NLX) = NTSTRT
         TX = NTSTRT
         NTSTRT = TX + NLWRDS
C        'IF' (NTSTRT .GE. NTSTOP)
C           NAME TEXT OVERFLOW
C           NTEXTX (NLX) = -1
C           TX = MODTXT (DUMMY)
C           'ENDIF'
         IF (NTSTRT .GE. NTSTOP) CALL FATAL (19)
         NLENO = NLENO + 1
         CALL MOVE (NAME, NTEXT (TX), NLWRDS)
         NLIST (NLX) = ISHFT (STDMD, MSHIFT)
         NLOC (NLX) = -1
         'ELSE'
         IF (NLTEST (NLX, REGBIT)) ^
            REGCNT = REGCNT + 1
         'IF' (PARFLG .NE. 0 .AND. IAND (NTEMP, OPBIT) .EQ. 0)
C           PARAMETER ERROR
            FNLX = NLX
            CALL FAULTP (18)
            'ENDIF'
         'ENDIF'
      I = ITS
      K = KTS
      RETURN
      END
      'OUTFILE' ENTNUMFTM.FR
C     INTEGER FUNCTION ENTNUM
C
C     DEFINE THE BINARY VALUE OF 'NUMBER' AS NAME IN NAME LIST
C
      INTEGER FUNCTION ENTNUM (DUM)
      'INCLUDE' NLISTCFTM.IN,
      'INCLUDE' NLNAMEFTM.IN,
      'INCLUDE' LOGOSAJH.IN,
      INTEGER  DUM
C     SET LENGTH = 3 CHARACTERS, CHAR 1 = 01
      CALL PCHAR (NAME, 1, 3)
      CALL PCHAR (NAME, 2, 1)
      ENFLAG = 0
      NAME (2) = NUMBER
      'IF' (NUMBER .LT. 0 .OR. NUMBER .GT. 255 ^
         .OR. SPECMD .EQ. DPMODE)
C        CONSTANT MUST BE DOUBLE PRECISION
         ENFLAG = DPBIT
         'ENDIF'
      CALL SEARCH
      'IF' (ENFLAG .NE. 0)
C        MODE NEEDS TO BE SET
         CALL NLVAL (NLX, ENFLAG, MDMASK)
         'ENDIF'
      CFLAG = CBIT
      CALL NLSET (NLX, CBIT)
      'IF' (FNLX .EQ. 0)
C        SET INDEX OF FIRST NAME LIST ENTRY
         FNLX = NLX
         'ENDIF'
      ENTNUM = NLX
      RETURN
      END
      'OUTFILE' NLOPSFTM.FR
C     INTEGER FUNCTION NLOPS
C
C     ACCEPTS A FUNCTION CODE FOR THE FOLLOWING FUNCTIONS:
C        DFINED   1     DEFINED
C        CVALUE   2     CVALUE
C        NLXLCI   3     NLX LCI
C        ENEXDT   4     ENTER EXTD
C        NAMAT0   5     NAME AT ZERO
C        NAMCON   6     NAME CONSTANT
C        NLMODE   7     NL MODE
C        NAMLOC   8     NAME LOCATION
C        REGNUM   9     REGISTER NUMBER
C
C     THE NAME LIST INDEX IS EXPLICITLY PASSED AS THE SECOND
C     PARAMETER.  ENEXTD RETURNS NO FUNCTION VALUE;  ALL OTHER
C     FUNCTIONS EXCEPT NLMODE PLACE THE VALUE RETURNED IN ENFLAG.
C
      INTEGER FUNCTION NLOPS (FUNC, INDEX)
      'INCLUDE' NLISTCFTM.IN,
      'INCLUDE' NLARAYFTM.IN,
      INTEGER FUNC, INDEX, TS
      INTEGER GETTX, GCHAR
      LOGICAL     NLTEST
C     CHOOSE FUNCTION
      GO TO (100, 200, 300, 400, 500, 600, 700, 800, 900) FUNC
C     DFINED
100   'IF' (NLOC (INDEX) .EQ. -1 ^
            .AND. IAND (NLIST (INDEX), LCMASK) .EQ. 0)
         NLOPS = 0
         'ELSE'
         NLOPS = 1
         'ENDIF'
      RETURN
C     CVALUE
200   NLOPS = GETTX (INDEX) + 1
      NLOPS = NTEXT (NLOPS)
      RETURN
C     NLXLCI
300   NLOPS = IAND (NLIST (INDEX), LCMASK)
      RETURN
C     ENEXTD
400   CALL NLSET (INDEX, EXDBIT)
      RETURN
      'EJECT'
C     NAMAT0
500   'IF' (IAND (NLIST (INDEX), LCMASK + PBIT) .EQ. LCMASK)
         NLOPS = NLOC (INDEX)
         'ELSE'
         NLOPS = 1
         'ENDIF'
      RETURN
C     NAMCON
600   TS = GETTX (INDEX)
      TS = GCHAR (NTEXT (TS), 2)
      'IF' (NLTEST (INDEX, CBIT) .AND. TS .GT. 3)
         NLOPS = 1
         'ELSE'
         NLOPS = 0
         'ENDIF'
      RETURN
C     NLMODE
700   NLOPS = ISHFT (IAND (NLIST (INDEX), MDMASK), -MSHIFT)
      RETURN
C     LOCATION OR REGISTER NUMBER
800   CONTINUE
900   NLOPS = NLOC (INDEX)
      RETURN
      END
      'OUTFILE' GETTXFTM.FR
C     SUBROUTINE GETTX
C
C     ACCEPTS AN EXPLICIT NAME LIST INDEX AND, IF THE NAME TEXT
C     FOR THAT ENTRY RESIDES ON DISC, RETRIEVES THE TEXT FOR
C     USE.
C
      INTEGER FUNCTION GETTX (INDEX)
      'INCLUDE' NLISTCFTM.IN,
      'INCLUDE' NLARAYFTM.IN,
      INTEGER  INDEX
      TX = NTEXTX (INDEX)
C*****IF TEXT IS ON DISC, CALL 'TEXT FROM FILE'
      GETTX = TX
      RETURN
      END
      'OUTFILE' CLOCNFTM.FR
C     INTEGER FUNCTION CLOCN
C
C     ACCEPTS AN EXPLICIT NAME LIST INDEX AND CONVERTS THE NAME
C     (OR, FOR CONSTANTS, THE VALUE) INTO ASCII IN ARRAY 'NAME'.
C     THE RETURN VALUE IS THE CHARACTER COUNT.
C
      INTEGER FUNCTION CLOCN (INDEX)
      'INCLUDE' NLISTCFTM.IN,
      'INCLUDE' NLARAYFTM.IN,
      'INCLUDE' NLNAMEFTM.IN,
      'INCLUDE' LOGOSAJH.IN,
      INTEGER II, ITX, INDEX
      INTEGER GETTX, GCHAR, NLOPS
      CALL SET (XBBL, NAME, 9)
      ITX = GETTX (INDEX)
      CLOCN = IAND (GCHAR (NTEXT (ITX), 1), 31)
      'IF' (GCHAR (NTEXT (ITX), 2) .GT. 3)
C        NAME, CONVERT ASCII
         'DOLOOP' II = 1, CLOCN
            CALL PCHAR (NAME, II, GCHAR (NTEXT (ITX), II+1))
            'END'
         'ELSE'
         CALL EHX (NLOPS (CVALUE, INDEX), NAME, 1, 6)
         CLOCN = 6
         'ENDIF'
      RETURN
      END
      'OUTFILE'   MODTXTFTM.FR
C     INTEGER FUNCTION MODTXT
C
C     DUMMY FOR NOW
C
      INTEGER FUNCTION MODTXT (INDEX)
      'INCLUDE'   NLISTCFTM.IN,
      'INCLUDE'   NLARAYFTM.IN,
      INTEGER     INDEX
      MODTXT = NTEXTX (INDEX)
      TX = MODTXT
      RETURN
      END
      'OUTFILE' NLSCANFTM.FR
      SUBROUTINE NLSCAN (PROG, INDEX)
      'INCLUDE' NLISTCFTM.IN,
      'INCLUDE' NLARAYFTM.IN,
      INTEGER  NLEND, TS
      INTEGER  GETTX, GCHAR
      LOGICAL     NLTEST
      INTEGER  INDEX
      NLEND = NLSTOP
      'DOLOOP' INDEX = NLSTRT, NLEND
         TS = GETTX (INDEX)
         'IF' (TS .NE. 0)
            TS = GCHAR (NTEXT (TS), 1)
            'IF' (NTEXTX (INDEX) .NE. 0 ^
                  .AND. .NOT. NLTEST (INDEX, REGBIT) ^
                  .AND. IAND (TS, OPBIT) .EQ. 0)
               CALL PROG
               'ENDIF'
            'ENDIF'
         'END'
      RETURN
      END
      'OUTFILE' NDEFNFTM.FR
C     SUBROUTINE NDEFN
C
C     CHECKS FOR PRIOR USE OF NAME AT TIME OF DEFINITION
C
      SUBROUTINE NDEFN
      'INCLUDE'   LOGOSAJH.IN,
      'INCLUDE'   OPERSAJH.IN,
      'INCLUDE'   NLISTCFTM.IN,
      'INCLUDE'   NLARAYFTM.IN,
      'INCLUDE'   BLDPOAJH.IN,
      'INCLUDE' LCONSTAJH.IN,
      INTEGER  NTEMP
      INTEGER  NLOPS
      'IF' (NLOPS (DFINED, NLX) .NE. 0)
C        NAME HAS BEEN DEFINED
         'IF' (NLOC (NLX) .EQ. LC ^
               .AND. IAND (NLIST (NLX), LCMASK) .EQ. LCI)
C           ENTRY POINT
            CALL NLSET (NLX, EPBIT)
            'ELSE'
            CALL FAULTP (18)
            'ENDIF'
         'ELSE'
         CALL PUSH (NLX, TX, TX)
         NLX = FNLX
         IF (NLOPS (NAMCON, NLX) .NE. 0) CALL FAULTP (18)
         CALL POP (NLX, TX, TX)
         CALL LIST (LLNAME, NLX, 0)
         NTEMP = NLIST (NLX)
         'IF' (DEFMOD .NE. STDMD ^
               .AND. IAND (NTEMP, MDMASK + STRBIT) ^
                     .EQ. ISHFT (STDMD, MSHIFT))
C           STANDARD MODE, CHECK FOR ILLICIT USE
            'IF' (DEFMOD .EQ. DPMODE ^
                  .AND. IAND (NTEMP, IOBIT + ARBIT) .NE. 0 ^
                  .OR. DEFMOD .GT. DPMODE ^
                  .AND. IAND (NTEMP, IOBIT) .NE. 0)
C              "NAME USED BEFORE DEFINITION"
               CALL FAULTP (17)
               'ENDIF'
            'ENDIF'
         NLIST (NLX) = IOR (ISHFT (DEFMOD, MSHIFT) + LCI + TPFLAG, ^
                            IAND (NTEMP, NOT (MDMASK + EXDBIT)))
         IF (IOTYPE .EQ. ST) ^
            CALL NLSET (NLX, STRBIT)
         NLOC (NLX) = LC
         'ENDIF'
      RETURN
      END