C Copyright(C) 1999-2020 National Technology & Engineering Solutions C of Sandia, LLC (NTESS). Under the terms of Contract DE-NA0003525 with C NTESS, the U.S. Government retains certain rights in this software. C C See packages/seacas/LICENSE for details 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