C    Copyright(C) 2008 Sandia Corporation.  Under the terms of Contract
C    DE-AC04-94AL85000 with Sandia Corporation, the U.S. Government retains
C    certain rights in this software
C    
C    Redistribution and use in source and binary forms, with or without
C    modification, are permitted provided that the following conditions are
C    met:
C    
C    * Redistributions of source code must retain the above copyright
C       notice, this list of conditions and the following disclaimer.
C              
C    * Redistributions in binary form must reproduce the above
C      copyright notice, this list of conditions and the following
C      disclaimer in the documentation and/or other materials provided
C      with the distribution.
C                            
C    * Neither the name of Sandia Corporation nor the names of its
C      contributors may be used to endorse or promote products derived
C      from this software without specific prior written permission.
C                                                    
C    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
C    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
C    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
C    A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
C    OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
C    SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
C    LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
C    DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
C    THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
C    (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
C    OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
C    

C=======================================================================
      SUBROUTINE LOCEQV (NAMECO, NAMES,
     &   NUMENT, NAMENT, TYPENT, INXENT, VALENT, ITMENT, IEVENT, VSZENT,
     &   ISEVOK, IDEFEV, NUMEV, MAXSTK, NERR)
C=======================================================================

C   --*** LOCEQV *** (ALGEBRA) Locate equation variables and add to list
C   --   Written by Amy Gilkey - revised 05/25/88
C   --
C   --LOCEQV determines the type, location, and node/element specific (if any)
C   --of an equation's variables.  The variable names, types, and
C   --database indices (for input variables) are added to the /VAR../
C   --arrays.
C   --
C   --The variable name in the NAMVAR array is stripped of any specifier
C   --to eliminate multiple references to a single variable.
C   --The node/element specifier is stored in VALENT and associated with
C   --the equation reference.  Similarly, all global input variables are
C   --assigned one dummy name, and the variable number is stored in VALENT.
C   --
C   --If there have been no errors up to this point, the equation is in
C   --postfix form.  Each entry in the equation is assigned a number
C   --representing the number of items expected after the entry is put
C   --on the stack.  With a nodal or element variable (or an action
C   --involving such a variable), this is simply the number of nodes or
C   --elements.  With a constant, TIME or global variable, this may be
C   --one or the number of nodes or element if the value must be converted
C   --to an array.
C   --
C   --Parameters:
C   --   NAMECO - IN - the coordinate names
C   --   NAMES - IN - the global, nodal, and element variable names
C   --   NUMENT - IN - the number of entries (as in /ENT../)
C   --   NAMENT - IN/OUT - the equation entries (as in /ENT../)
C   --   TYPENT - IN - the type of each equation entry (as in /ENT../)
C   --   INXENT - IN/OUT - based on TYPENT (as in /ENT../)
C   --   VALENT - IN/OUT - based on TYPENT (as in /ENT../)
C   --   ITMENT - IN/OUT - based on TYPENT (as in /ENT../)
C   --   IEVENT - IN/OUT - the ISEVOK index for this entry (as in /ENT../)
C   --   VSZENT - OUT - the type of variable on the stack after processing
C   --      this entry (as in /ENT../)
C   --   ISEVOK - IN/OUT - the element variable truth table;
C   --      includes input, temporary, and output variables
C   --   IDEFEV - IN - the default ISEVOK variable index
C   --   NUMEV - IN/OUT - the maximum ISEVOK variable index
C   --   MAXSTK - OUT - the maximum stack size for this equation
C   --   NERR - IN/OUT - the number of errors in the equation, may be set
C   --
C   --Common Variables:
C   --   Sets NUMINP, IXLHS, NAMVAR, TYPVAR, IDVAR, ISTVAR, IEVVAR of /VAR../
C   --   Uses NDIM, NUMNP, NUMEL, NVARNP, NVAREL, NVARGL of /DBNUMS/
C   --   Uses FNCTYP of /FNCTB./

      include 'exodusII.inc'
      include 'ag_namlen.blk'
      include 'ag_numeqn.blk'
      include 'ag_var.blk'
      include 'ag_dbnums.blk'
      include 'ag_fnctbc.blk'
      PARAMETER (ICURTM = 1, ILSTTM = 2, IONETM = 3)

      CHARACTER*(*) NAMECO(*)
      CHARACTER*(*) NAMES(*)
      CHARACTER*(*) NAMENT(*)
      CHARACTER TYPENT(*)
      INTEGER INXENT(*)
      REAL VALENT(*)
      INTEGER ITMENT(*)
      INTEGER IEVENT(*)
      CHARACTER VSZENT(*)
      LOGICAL ISEVOK(NELBLK,*)

      CHARACTER*(maxnam) NAME
      CHARACTER TYPEQV
      CHARACTER VTYP
      LOGICAL ALLSAM
      CHARACTER*5 STRA, STRB

      CHARACTER TYPSTK(MAXENT)
      INTEGER INXSTK(MAXENT)
C      --TYPSTK - type of variables for stack item
C      --INXSTK - equation entry which pushed this stack item

C   --Save the /VAR../ indices so they can be restored in case of error
      NINP = NUMINP
      ILHS = IXLHS

C   --Set up to check postfix stack if no errors so far
      ITOS = 0
      INERR = NERR
      IF (INERR .NE. 0) TYPSTK(1) = 'G'

      MAXSTK = 0

      VTYP = ' '
      DO 100 NENT = 1, NUMENT
         IEVENT(NENT) = -999
  100 CONTINUE

      DO 180 NENT = 3, NUMENT

         IF (TYPENT(NENT) .EQ. 'V') THEN

C         --Get the name and the node/element specifier, if any

            NAME = NAMENT(NENT)
            NENUM = INT(VALENT(NENT))

C         --Locate where the variable name is in the list of variables

            CALL LOCNAM (NAME, NAMECO, NAMES,
     &         NENUM, TYPEQV, IDEQV, NERR)

C         --Reference variable from entry

            VALENT(NENT) = NENUM
            IF (IDEQV .LT. 0) THEN
               INXENT(NENT) = -1
            ELSE
               INXENT(NENT) = +1
            END IF
C            --Set INXENT -1 for reference to LHS variable, +1 for
C            --input variable; used to link variables
            IF (TYPEQV .EQ. 'E') THEN
               NEWEV = NUMEV + 1
               IEVOLD = IDEFEV
               IF (IDEQV .GE. 0) THEN
                  IEVNEW = IDEQV
               ELSE
                  IEVNEW = IEVVAR(IABS(IDEQV))
               END IF
               CALL MAKEVO (NELBLK, ISEVOK,
     &            IEVOLD, IEVNEW, NEWEV, IEVOLD)
               NEWEV = IEVOLD
               IF (NEWEV .GT. NUMEV) NUMEV = NEWEV
               IEVENT(NENT) = NEWEV
            ELSE
               IEVENT(NENT) = -999
            END IF

C         --Correct variable name to eliminate duplicate references in
C         --the variable array

            IF (((TYPEQV .EQ. 'H') .OR. (TYPEQV .EQ. 'G'))
     &         .AND. (IDEQV .GE. 0)) THEN
C            --Input history and global variables are all in the same entry
               IF (TYPEQV .EQ. 'H') THEN
                  NAME = '.GLOBAL'
               ELSE
                  NAME = '.GLOBAL'
               END IF
               NAMENT(NENT) = NAME
            END IF

C         --Insert name in list of input variables, if not LHS and not
C         --already there; update time reference

            IF (TYPEQV .EQ. 'C') ITMENT(NENT) = ICURTM
            IF (IDEQV .GE. 0) THEN
               IVAR = LOCSTR (NAME, NUMINP, NAMVAR)
               IF (IVAR .LE. 0) THEN
                  NUMINP = NUMINP + 1
                  IVAR = NUMINP
                  IF (NUMINP .LT. IXLHS) THEN
                     NAMVAR(IVAR) = NAME
                     TYPVAR(IVAR) = TYPEQV
                     IDVAR(IVAR) = IDEQV
                     ISTVAR(ICURTM,IVAR) = 0
                     ISTVAR(ILSTTM,IVAR) = 0
                     ISTVAR(IONETM,IVAR) = 0
                     IF (TYPEQV .EQ. 'E') THEN
                        IEVVAR(IVAR) = IDEQV
                     ELSE
                        IEVVAR(IVAR) = -999
                     END IF
                  END IF
               END IF
               ITM = ITMENT(NENT)
               ISTVAR(ITM,IVAR) = 1
            ELSE
               ITM = ITMENT(NENT)
               IF (ITM .NE. ICURTM) THEN
                  NUMLHS = MAXVAR - IXLHS + 1
                  IVAR = LOCSTR (NAME, NUMLHS, NAMVAR(IXLHS))
                  IF (IVAR .GT. 0) THEN
                     IVAR = IXLHS + IVAR - 1
                     ISTVAR(ITM,IVAR) = 1
                  END IF
               END IF
            END IF

C         --Get the variable type to check arrays

            IF ((TYPEQV .EQ. ' ') .OR. (TYPEQV .EQ. 'T') .OR.
     *               (TYPEQV .EQ. 'G')) THEN
               VTYP = 'G'
             ELSE IF (TYPEQV .EQ. 'H') THEN
               VTYP = 'H'
            ELSE
               IF (NENUM .NE. 0) THEN
                  VTYP = 'G'
               ELSE IF (TYPEQV .EQ. 'C') THEN
                  VTYP = 'N'
               ELSE
                  VTYP = TYPEQV
               END IF
            END IF
         END IF

C      --Get the equation variable type, and check for mixed array errors

         IF (INERR .EQ. 0) THEN

C         --Check by manipulating the postfix string

            IF (TYPENT(NENT) .EQ. 'C') THEN

C            --Constant - push global type

               ITOS = ITOS + 1
               IF (ITOS .GT. MAXENT) GOTO 190
               MAXSTK = MAX (MAXSTK, ITOS)

               TYPSTK(ITOS) = 'G'
               INXSTK(ITOS) = NENT
               VSZENT(NENT) = 'G'

            ELSE IF (TYPENT(NENT) .EQ. 'V') THEN

C            --Variable - push variable array type

               ITOS = ITOS + 1
               IF (ITOS .GT. MAXENT) GOTO 190
               MAXSTK = MAX (MAXSTK, ITOS)

               TYPSTK(ITOS) = VTYP
               INXSTK(ITOS) = NENT
               VSZENT(NENT) = VTYP

            ELSE IF (TYPENT(NENT) .EQ. 'O') THEN

C            --Operator - pop operands, push type of any operand array

               IF (INXENT(NENT) .LE. 1) THEN
                  NOP = 1
               ELSE
                  NOP = 2
               END IF
               IOP1 = ITOS - NOP + 1
               ILAST = ITOS
               ITOS = IOP1
               IF (ITOS .LE. 0) GOTO 190

               ALLSAM = .TRUE.
               VTYP = TYPSTK(IOP1)
               DO 110 I = IOP1+1, ILAST
                  IF (VTYP .NE. TYPSTK(I)) ALLSAM = .FALSE.
                  IF (TYPSTK(I) .NE. VTYP) THEN
                     IF (TYPSTK(I) .EQ. 'H') THEN
                        CONTINUE
                     ELSE IF (TYPSTK(I) .EQ. 'G') THEN
                        IF ((VTYP .EQ. 'T') .OR. (VTYP .EQ. 'H'))
     &                     VTYP = TYPSTK(I)
                     ELSE IF ((TYPSTK(I) .EQ. 'N')
     &                  .OR. (TYPSTK(I) .EQ. 'E')) THEN
                        IF ((VTYP .EQ. 'N') .OR. (VTYP .EQ. 'E')) THEN
                           IF (TYPSTK(I) .NE. VTYP) VTYP = '?'
                        ELSE
                           IF (VTYP .NE. '?') VTYP = TYPSTK(I)
                        END IF
                     ELSE IF (TYPSTK(I) .EQ. '?') THEN
                        VTYP = TYPSTK(I)
                     END IF
                  END IF
  110          CONTINUE

               IF (VTYP .EQ. 'E') THEN
                  NEWEV = NUMEV + 1
                  IEVOLD = IDEFEV
                  DO 120 I = IOP1, ILAST
                     IF (TYPSTK(I) .EQ. 'E') THEN
                        IEVNEW = IEVENT(INXSTK(I))
                        CALL MAKEVO (NELBLK, ISEVOK,
     &                     IEVOLD, IEVNEW, NEWEV, IEVOLD)
                     END IF
  120             CONTINUE
                  NEWEV = IEVOLD
                  IF (NEWEV .GT. NUMEV) NUMEV = NEWEV
                  IEVENT(NENT) = NEWEV
               END IF

               IF (.NOT. ALLSAM) THEN
                  DO 130 I = IOP1, ILAST
                     IF (VTYP .NE. TYPSTK(I)) THEN
                        VSZENT(INXSTK(I)) = VTYP
                     END IF
  130             CONTINUE
               END IF

               TYPSTK(ITOS) = VTYP
               INXSTK(ITOS) = NENT
               VSZENT(NENT) = VTYP

            ELSE IF (TYPENT(NENT) .EQ. 'F') THEN

C            --Function - pop parameters and push type of function

               NPARM = INT(VALENT(NENT))
               IPARM = ITOS - NPARM + 1
               ILAST = ITOS
               ITOS = IPARM
               IF (ITOS .LE. 0) GOTO 190

               IF (FNCTYP(INXENT(NENT)) .EQ. ' ') THEN

C               --Get function type from parameter types

                  ALLSAM = .TRUE.
                  VTYP = TYPSTK(IPARM)
                  DO 140 I = IPARM+1, ILAST
                     IF (VTYP .NE. TYPSTK(I)) ALLSAM = .FALSE.
                     IF (TYPSTK(I) .NE. VTYP) THEN
                        IF (TYPSTK(I) .EQ. 'H') THEN
                           CONTINUE
                        ELSE IF (TYPSTK(I) .EQ. 'G') THEN
                           IF (VTYP .EQ. 'H') VTYP = TYPSTK(I)
                        ELSE IF ((TYPSTK(I) .EQ. 'N')
     &                     .OR. (TYPSTK(I) .EQ. 'E')) THEN
                           IF ((VTYP .EQ. 'N')
     &                        .OR. (VTYP .EQ. 'E')) THEN
                              IF (TYPSTK(I) .NE. VTYP) VTYP = '?'
                           ELSE
                              IF (VTYP .NE. '?') VTYP = TYPSTK(I)
                           END IF
                        ELSE IF (TYPSTK(I) .EQ. '?') THEN
                           VTYP = TYPSTK(I)
                        END IF
                     END IF
  140             CONTINUE

                  IF (.NOT. ALLSAM) THEN
                     DO 150 I = IPARM, ILAST
                        IF (VTYP .NE. TYPSTK(I)) THEN
                           VSZENT(INXSTK(I)) = VTYP
                        END IF
  150                CONTINUE
                  END IF

               ELSE

C               --Function has a defined type, parameters may be mixed types

                  VTYP = FNCTYP(INXENT(NENT))
                  DO 160 I = IPARM, ILAST
                     IF (TYPSTK(I) .EQ. '?') VTYP = TYPSTK(I)
                     IF ((TYPSTK(I) .EQ. 'H')
     &                  .OR. (TYPSTK(I) .EQ. 'G')) THEN
                        VSZENT(INXSTK(I)) = '*'
                     END IF
  160             CONTINUE
               END IF

               NEV = 0
               NEWEV = NUMEV + 1
               IEVOLD = IDEFEV
               DO 170 I = IPARM, ILAST
                  IF (TYPSTK(I) .EQ. 'E') THEN
                     NEV = NEV + 1
                     IEVNEW = IEVENT(INXSTK(I))
                     CALL MAKEVO (NELBLK, ISEVOK,
     &                  IEVOLD, IEVNEW, NEWEV, IEVOLD)
                  END IF
  170          CONTINUE
               IF (NEV .GT. 0) THEN
                  NEWEV = IEVOLD
                  IF (NEWEV .GT. NUMEV) NUMEV = NEWEV
                  IEVENT(NENT) = NEWEV
               END IF

               TYPSTK(ITOS) = VTYP
               INXSTK(ITOS) = NENT
               VSZENT(NENT) = VTYP
            END IF

         ELSE

C         --Do simple check that variable types match since postfix string
C         --is incorrect

            IF (TYPENT(NENT) .EQ. 'V') THEN

C            --Check that there are no mixed array types

               IF (TYPSTK(1) .NE. ' ') THEN
                  IF (TYPSTK(1) .NE. VTYP) THEN
                     IF (TYPSTK(1) .EQ. 'H') THEN
                        CONTINUE
                     ELSE IF (TYPSTK(1) .EQ. 'G') THEN
                        IF (VTYP .EQ. 'H') VTYP = TYPSTK(1)
                     ELSE IF ((TYPSTK(1) .EQ. 'N')
     &                  .OR. (TYPSTK(1) .EQ. 'E')) THEN
                        IF ((VTYP .EQ. 'N') .OR. (VTYP .EQ. 'E')) THEN
                           IF (TYPSTK(1) .NE. VTYP) VTYP = '?'
                        ELSE
                           IF (VTYP .NE. '?') VTYP = '?'
                        END IF
                     ELSE IF (TYPSTK(1) .EQ. '?') THEN
                        VTYP = TYPSTK(1)
                     END IF
                  END IF
               END IF

            ELSE IF (TYPENT(NENT) .EQ. 'F') THEN

C            --If defined-type function is present, do not check array types

               IF (FNCTYP(INXENT(NENT)) .NE. ' ') THEN
                  IF (TYPSTK(1) .NE. '?') TYPSTK(1) = ' '
               END IF
            END IF

         END IF
  180 CONTINUE

      IF (TYPENT(1) .EQ. 'V') THEN

         NAME = NAMENT(1)

C      --Specifier is not valid on the assigned variable

         IF (VALENT(1) .GT. 0) THEN
            NERR = NERR + 1
            CALL PRTERR ('CMDSPEC', 'Node/element specifier not allowed'
     &         // ' on assigned variable')
         END IF

         IF (ITMENT(1) .NE. ICURTM) THEN
            NERR = NERR + 1
            CALL PRTERR ('CMDSPEC', 'Time specifier not allowed'
     &         // ' on assigned variable')
         END IF

         INXENT(1) = -1
C         --Set INXENT -1 for reference to LHS variable
         VALENT(1) = 0
         IF (TYPEQV .EQ. 'E') THEN
            IEVENT(1) = NEWEV
         ELSE
            IEVENT(1) = -999
         END IF

      ELSE
         NAME = ' '
      END IF

C   --Assign and check the type for the assigned variable

      IF (TYPSTK(1) .EQ. '?') THEN
         TYPEQV = 'G'
         NERR = NERR + 1
         CALL PRTERR ('CMDSPEC',
     &      'Nodal and element variables are mixed')
      ELSE
         TYPEQV = TYPSTK(1)
      END IF
      VSZENT(1) = TYPEQV

      IF (NAME .EQ. 'TIME') THEN
         IF (TYPEQV .NE. 'G') THEN
            NERR = NERR + 1
            CALL PRTERR ('CMDSPEC', 'TIME must be a global variable')
         END IF
         TYPEQV = 'T'
      END IF

C   --If the assigned variable does not exist, add it to the list,
C   --else check that its type has not changed

      NUMLHS = MAXVAR - IXLHS + 1
      IVAR = LOCSTR (NAME, NUMLHS, NAMVAR(IXLHS))

      IF (IVAR .LE. 0) THEN
         IXLHS = IXLHS - 1
         IF (NUMINP .LT. IXLHS) THEN
            NAMVAR(IXLHS) = NAME
            TYPVAR(IXLHS) = TYPEQV
            IDVAR(IXLHS) = -999
            ISTVAR(ICURTM,IXLHS) = 1
            ISTVAR(ILSTTM,IXLHS) = 0
            ISTVAR(IONETM,IXLHS) = 0
            IF (TYPEQV .EQ. 'E') THEN
               IEVVAR(IXLHS) = NEWEV
            ELSE
               IEVVAR(IXLHS) = -999
            END IF
         END IF
      ELSE
         IVAR = IXLHS + IVAR - 1
         IF (TYPEQV .NE. TYPVAR(IVAR)) THEN
            IF (TYPEQV .NE. ' ') THEN
               NERR = NERR + 1
               CALL PRTERR ('CMDSPEC', NAME(:LENSTR(NAME))
     &            // ' was previously assigned as a different type')
            END IF
         END IF

C      --Change DELETEd or SAVEd variable to assigned variable
         IF ((NERR .EQ. 0) .AND. (ISTVAR(ICURTM,IVAR) .NE. 1))
     &      ISTVAR(ICURTM,IVAR) = 1
      END IF

      GOTO 200

  190 CONTINUE
      NERR = NERR + 1
      CALL PRTERR ('PROGRAM', 'Program stack problem in LOCEQV')

  200 CONTINUE

      IF (NUMINP .GE. IXLHS) THEN
         NERR = NERR + 1
         N = NUMINP + (MAXVAR - IXLHS + 1)
         CALL INTSTR (1, 0, N, STRA, LSTRA)
         CALL INTSTR (1, 0, MAXVAR, STRB, LSTRB)
         CALL PRTERR ('CMDSPEC',
     &      'Too many variable names to store, '
     &      // STRA(:LSTRA) // ' > ' // STRB(:LSTRB))
      END IF

      IF (NERR .GT. 0) THEN
         NUMINP = NINP
         IXLHS = ILHS
      END IF

      RETURN
      END
