EXODUS/packages/seacas/applications/algebra/algebra.f

C    Copyright(C) 1999-2022 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=======================================================================
      PROGRAM ALGEBRA2
C=======================================================================

C   --This version of ALGEBRA will read and write EXODUSIIV2 database
C   --format files.  Many changes have occurred since the first version
C   --of ALGEBRA.  The original database files, genesis and exodusI
C   --were sequential access files.  EXODUSIIV2 uses a random access
C   --file format. Previous versions of ALGEBRA would have to read the
C   --input database more than once in order to get the file pointer
C   --to the desired data.  With random access files we are able to
C   --select what we want to read or write at anytime.

C                         *** ALGEBRA 2.02 ***
C   --*** ALGEBRA *** (ALGEBRA) Algebraic Database Manipulation Program
C   --
C   --The ALGEBRA program allows the user to process data from a finite
C   --element analysis before it is plotted. The finite element output
C   --data is in the form of variable values (stress, strain, and
C   --velocity components, etc.) in an EXODUS database.  The ALGEBRA program
C   --evaluates user-supplied functions of the data and writes the results
C   --to an output EXODUS database which can be read by plot programs.
C   --
      include 'exodusII.inc'
      include 'ag_namlen.blk'

C     max_num_equation, max_parsed_entries
      include 'ag_numeqn.blk'
C     QAINFO array with program information
      include 'ag_progqa.blk'
C     input equation info
      include 'ag_ent.blk'
C     input variable info
      include 'ag_var.blk'
C     aliases
      include 'ag_alias.blk'
C     I/O file names
      include 'ag_dbase.blk'
C     I/O database titles
      include 'ag_dbtitl.blk'
C     num_of: nodes,elements,coordinated/node,element_blks
C     num_of: history,global,nodal,element variables, num_of_time_steps
      include 'ag_dbnums.blk'
C     node set/side sets number,length,dist factor
      include 'ag_dbnumg.blk'
C     database type, num_of qa and info records
      include 'ag_dbnumq.blk'
C     num_of: nodes,elements,element blks,node_sets,side_sets in zoom mesh
C     num_of: output history,global,nodal,element variables
      include 'ag_dbout.blk'
C     time_index, I_index/O_index for history,global,nodal and element vars
      include 'ag_dbxvar.blk'
C     time variables
      include 'ag_times.blk'
C     zoom info
      include 'ag_zoom.blk'
C     function variables
      include 'ag_fnctbc.blk'
C     equation line error messages
      include 'ag_eqnlns.blk'
C     floating point byte size
      include 'ag_dbws.blk'
      include 'argparse.inc'

C     Input/Output File Arguments
C     CPUWS - The word size in bytes of the floating point variables
C             used in the application program
C     IOWS  - The word size in bytes of the floating point data as they
C             are stored in the EXODUS II file
C     IERR  - error code
C     VERS  - version number of database
C     NERR  - error flag for dynamic memory errors
C     MERR  - memory error flag
C     IOERR - Input/output error flag
C      INTEGER CPUWS, IOWS, IERR, NERR, CERR, MERR
      INTEGER IERR, NERR, CERR, MERR
      REAL VERS
      LOGICAL MEMBUG
      CHARACTER*2048 FILNAM, SCRATCH

      CHARACTER*8 STR8

C     A - the dynamic memory base array
      DIMENSION A(1)
      CHARACTER*1 C(1)

C     Logical variables that indicate whether an input/output
C     file is open.  These variable are use during exit of the
C     program in hopes to cut down on the multitude of goto labels
C     while exiting the program
      LOGICAL INOPEN, OTOPEN

C     Executable code in qainfo.blk
      include 'ag_qainfo.blk'

      INOPEN = .FALSE.
      OTOPEN = .FALSE.
      MEMBUG = .FALSE.
      MERR   = 0
      IOERR  = 0

      CALL STRTUP (QAINFO)
      CALL BANNR2 (80, QAINFO(1), 0)
      CALL BANNER (0, QAINFO,
     &   'AN ALGEBRAIC MANIPULATION PROGRAM',
     &   'FOR POST-PROCESSING OF FINITE ELEMENT ANALYSES',
     &   'EXODUS II VERSION')
      CALL CPYRGT (0, '2008')
      WRITE(*,*)

C     Set compute and file float size to default values
C     values located in dbws.blk
      CPUWS=0
      IOWS=0

      IF (MEMBUG) THEN
         CALL MLIST()
      END IF

C     Input and Output File ID's
C     See Algebra script for more details
C     dbase.blk: COMMON /DBASE/ NDBIN, NDBOUT
      NDBIN = 11
      NDBOUT = 12

C     Open the log file - temporary file unless the user decides to save it
      NLOG = 99
      CALL OPNLOG (NLOG)

C .. Get filename from command line.  If not specified, emit error message
      NARG = argument_count()
      if (narg .lt. 2) then
        CALL PRTERR ('FATAL', 'Filenames not specified.')
        CALL PRTERR ('CMDSPEC',
     *    'Syntax is: "algebra file_in file_out"')
        CALL PRTERR ('CMDSPEC',
     *    'Documentation: https://sandialabs.github.io' //
     $       '/seacas-docs/sphinx/html/index.html#algebra')
        GOTO 150
      else if (narg .gt. 2) then
        CALL PRTERR ('FATAL', 'Too many arguments specified.')
        CALL PRTERR ('CMDSPEC',
     *    'Syntax is: "algebra file_in file_out"')
        CALL PRTERR ('CMDSPEC',
     *    'Documentation: https://sandialabs.github.io' //
     $       '/seacas-docs/sphinx/html/index.html#algebra')
        GOTO 150
      end if

C     Open the input database; Exit on error
      CALL get_argument(1,FILNAM, LFIL)
      ndbin = exopen(filnam(:lfil), EXREAD, cpuws, iows,
     &       vers, ierr)
      IF (IERR .NE. 0) THEN
        SCRATCH = 'Database "'//FILNAM(:LFIL)//'" does not exist.'
        CALL PRTERR ('FATAL', SCRATCH(:LENSTR(SCRATCH)))
        GOTO 150
      END IF

      call exinq(ndbin, EXDBMXUSNM, namlen, rdum, cdum, ierr)
      call exmxnm(ndbin, namlen, ierr)

      INOPEN = .TRUE.

C     Initialize the Memory Manager
      CALL MDINIT (A)
c      CALL MDFILL(0)
      CALL MCINIT (C)
      CALL MDSTAT (NERR, MEM)
      IF (NERR .GT. 0) THEN
C        Report dynamic memory error
         CALL MEMERR
C        Goto WRAPUP call and exit program
         GOTO 150
      END IF

C     Read the initial parameters from the database
C     ndbin  - file ID (input)
C     title  - title of input file dbtitl.blk
C     ndim   - number of coordinates per node dbnums.blk
C     numnp  - number of nodes dbnums.blk
C     numel  - number of elements dbnums.blk
C     nelblk - number of element blocks dbnums.blk
C     numnps - number of node sets dbnumg.blk
C     numess - number of side sets dbnumg.blk
C     ioerr   - error code
C     dbase.blk, dbtitl.blk, dbnums.blk, dbnumg.blk
      CALL EXGINI(NDBIN, TITLE, NDIM, NUMNP, NUMEL, NELBLK,
     &            NUMNPS, NUMESS, IERR)

C     if number of node sets > 0, gather node set information dbnumg.blk
      if (numnps .gt. 0) then
C        EXNSNL - request the length of the node set node list.
         CALL EXINQ (NDBIN, EXNSNL, LNPSNL, RDUM, CDUM, IERR)
C        EXNSDF - request the length of the node sets distribution factors list
         CALL EXINQ (NDBIN, EXNSDF, LNPSDF, RDUM, CDUM, IERR)
      else
         lnpsnl = 0
         lnpsdf = 0
      end if

C     if number of side sets > 0, gather side set information dbnumg.blk
      if (numess .gt. 0) then
C        EXSSNL request length of the side set node list
         CALL EXINQ (NDBIN, EXSSNL, LESSNL, RDUM, CDUM, IERR)
C        EXSSEL request the length of the side sets element list.
         CALL EXINQ (NDBIN, EXSSEL, LESSEL, RDUM, CDUM, IERR)
C        EXSSDF request the length of the side set distribution factors list
         CALL EXINQ (NDBIN, EXSSDF, LESSDF, RDUM, CDUM, IERR)
      else
         lessnl = 0
         lessel = 0
         lessdf = 0
      end if

C     Title of output db = title of input db dbtitl.blk
      TITLEO = TITLE

C     Print the database filename, title, and db initial variables
C     Cannot print global, element, or nodal info.  Data has not
C     been read from the input database yet.
      CALL DBPINI ('TIS', NDBIN, TITLE, NDIM, NUMNP, NUMEL, NELBLK,
     &             NUMNPS, LNPSNL, LNPSDF, NUMESS, LESSEL,
     &             LESSDF, IDUM, IDUM, IDUM, ' ')

cccc     DBLIST uses MDFIND to locate NUMELB, NUMLNK, NUMATR
cccc     Scan the connectivity to get the element block IDs
cccc     Read element block connectivity

C     call MxRSRV(array_name, ret_array_index, array_size)
C     IDELB: Element block ID's for each block
      CALL MDRSRV ('IDELB', KIDELB, NELBLK)
C     NUMELB: Number of elements in each block
      CALL MDRSRV ('NUMELB', KNELB, NELBLK)
C     NUMLNK: Number of nodes per element in each block
      CALL MDRSRV ('NUMLNK', KNLNK, NELBLK)
C     NUMATR: Number of attributes in each block
      CALL MDRSRV ('NUMATR', KNATR, NELBLK)
C     VISELB(i) = True iff element block i is to be written
      CALL MDRSRV ('VISELB', KVISEB, NELBLK)
C     BLKTYP: Element type
      CALL MCRSRV ('BLKTYP', KNMLB, NELBLK * MXSTLN)
C     Reserving space for the element block connectivity arrays
      CALL MDRSRV ('LINK', KLINK, 0)
C     Reserving space for the element block attributes
      CALL MDRSRV ('ATRIB', KATRIB, 0)
C     Check for dynamic memory errors
      CALL MDSTAT (NERR, MEM)
      CALL MCSTAT (CERR, MEM)
      IF ((NERR .GT. 0) .OR. (CERR .GT. 0)) THEN
         CALL MEMERR
         GOTO 130
      END IF

C     DBIELB reads and returns the following:
C     1. Element block ID's
C     2. Element type in each element block
C     3. Number of elements in each element block
C     4. Number of nodes per element in each element block
C     5. Number of attributes per element in each element block
C     6. If Option = A or * -> element block attributes
C     7. If Option = C or * -> element block connectivity
C     8. If Option = H or * -> read all header information
C     9. If Option = I or * -> read the element block ID's
C     Note: Element block ID's must be read for all options
C     DBIELB reads the element block information from the database.
C     An error message is displayed if the end of file is read.
      CALL DBIELB (NDBIN, '*', 1, NELBLK, A(KIDELB), A(KNELB),
     &     A(KNLNK), A(KNATR), C(KNMLB), A, IELNK, IEATR, MERR)
C     Exit program on memory error
      IF (MERR .EQ. 1) GO TO 130

C     QA and Information record number stored in dbnumq.blk
C     Request the number of QA records.  Return the value
C     as an integer in nqarec
      CALL EXINQ (NDBIN, EXQA, NQAREC, RDUM, CDUM, IERR)
C     Request the number of information records.  Return the
C     value as an integer in ninfo
      CALL EXINQ (NDBIN, EXINFO, NINFO, RDUM, CDUM, IERR)

C     Reserve contiguous block space for arrays QA and information records
C     Reserve nqarec for input file + 1 for the current run
      CALL MCGET(((nqarec+1)*4*MXSTLN) + (ninfo*MXLNLN))
C     Reserve space to read the QA and information records
      call MCRSRV('QAREC', kqarec, (nqarec+1) * 4 * MXSTLN)
      call MCRSRV('INFREC', kinfo, ninfo * MXLNLN)
      CALL MCSTAT (NERR, MEM)
      IF (NERR .GT. 0) THEN
         CALL MEMERR
         GOTO 130
      END IF

C     Read the QA and Information Records
      CALL DBIQA(NDBIN, '*', NQAREC, C(KQAREC), NINFO, C(KINFO))

C     Read the number of global, node, and element variables
C     Read number of global variables = nvargl
      call exgvp(ndbin, 'G', nvargl, ierr)

C     Read number of nodal variables = nvarnp
      call exgvp(ndbin, 'N', nvarnp, ierr)

C     Read number of element variables = nvarel
      call exgvp(ndbin, 'E', nvarel, ierr)

C     Reserve memory for coordinate array names
      CALL MCRSRV ('NAMECO', KNACOR, namlen*NDIM)
C     Reserve memory for global, node, and element variable
      CALL MCRSRV ('NAMES', KNAMES, namlen*(NVARGL+NVARNP+NVAREL))
C     Reserve memory for element variable truth table
      CALL MDRSRV ('ISEVOK', KIEVOK, NELBLK * NVAREL)
C     Temporary storage
      CALL MDRSRV ('ITMP', KITMP,  NELBLK * NVAREL)
      CALL MCSTAT (CERR, MEM)
      CALL MDSTAT (NERR, MEM)
      IF ((NERR .GT. 0) .OR. (CERR .GT. 0))  THEN
         CALL MEMERR
         MERR = 1
         GOTO 130
      END IF

C     Read the coordinate names
      CALL DBICON (NDBIN, NDIM, C(KNACOR))
      IF (IOERR .EQ. 1) GO TO 130

C     Read the names of the global, node, and element variables
      CALL DBINAM (NDBIN, C, C(KNAMES), NVARGL, NVARNP, NVAREL,
     &             KNAMGV, KNAMNV, KNAMEV, MAXVAR)

C     Print database variable names
C     call dbpnam (option, num_glb_var, num_nod_var, num_elem_var,
C                  glb_var_names, nod_var_names, elem_var_names)
      CALL DBPNAM ('*', NVARGL, NVARNP, NVAREL,
     &             C(KNAMES+NAMLEN*(KNAMGV-1)),
     &             C(KNAMES+NAMLEN*(KNAMNV-1)),
     &             C(KNAMES+NAMLEN*(KNAMEV-1)))

C     Read the element variable truth table
      CALL DBIVTT (NDBIN, A(KIEVOK), A(KITMP), NELBLK, NVAREL)

C     Delete temporary dynamic memory
      CALL MDDEL('ITMP')
      CALL MDSTAT (NERR, MEM)
      if (NERR .GT. 0) then
         CALL MEMERR
         merr = 1
         GO TO 130
      end if

C     Request the number of time steps from the database
      CALL EXINQ (NDBIN, EXTIMS, NSTEPS, RDUM, CDUM, IERR)
C     Reserve memory to hold the time step values
C     Reserve memory for step times
      CALL MDRSRV ('TIMES', KTIMES, max(1,NSTEPS))
      CALL MDSTAT (NERR, MEM)
      IF (NERR .GT. 0) THEN
        CALL MEMERR
        MERR = 1
        GO TO 130
      END IF
      if (nsteps .gt. 0) then
        CALL EXGATM(NDBIN, A(KTIMES), IERR)
      else
C        Add a dummy step at time 0 in case user is trying to add a new step
        A(KTIMES) = 0.0
      END IF

C     Displays the number of time steps and the minimum and
C     maximum time on the database
C     'NM'   Print the number of time steps and the minimum and
C            maximum time step times
C     NSTEPS The number of time steps
C     A(KTIMES) The database time steps
      CALL DBPTIM ('NM', NSTEPS, A(KTIMES))

C     Selected time steps
      CALL MDRSRV ('IPTIMS', KPTIMS, MAX(1,NSTEPS))
C     selected element blocks
      CALL MDRSRV ('SELELB', KSELEB, NELBLK)
      CALL MDSTAT (NERR, MEM)
      IF (NERR .GT. 0) THEN
         CALL MEMERR
         MERR = 1
         GOTO 130
      END IF

C ... See if the input database has any nodeset or sideset variables.
C     If there are any, then output a warning message telling the user
C     that these are not supported in algebra and will be stripped from
C     output file.
      call exgvp(ndbin, 'M', nvarns, ierr)
      call exgvp(ndbin, 'S', nvarss, ierr)
      if (nvarns .gt. 0) then
         CALL PRTERR('WARNING',
     $        'The Input Database contains NODESET VARIABLES')
         CALL PRTERR('CMDSPEC',
     $        '      NODESET VARIABLES are not supported by algebra')
         CALL PRTERR('CMDSPEC',
     $        '      These will NOT be saved to the output database')
      end if
      if (nvarss .gt. 0) then
         CALL PRTERR('WARNING',
     $        'The Input Database contains SIDESET VARIABLES')
         CALL PRTERR('CMDSPEC',
     $        '      SIDESET VARIABLES are not supported by algebra')
         CALL PRTERR('CMDSPEC',
     $        '      These will NOT be saved to the output database')
      end if

C     Read in the equations
C     call rdeqns(DMarray, DCarray, coord_names, elem_names, db_var_names,
C     qa_rec, info_rec, db_time_step, select_time_step,
C     elem_blk_ids, TRUE_IFF_elem(i)_written, DMindex_ISEVOK,
C     max_stack_size, return_if_quit)

      CALL RDEQNS (A, C, C(KNACOR), C(KNMLB), C(KNAMES), C(KQAREC),
     &             C(KINFO),  A(KTIMES), A(KPTIMS), A(KSELEB),
     &             A(KIDELB), A(KVISEB), KIEVOK, MAXSTK, NLOG, MERR)
      IF (MERR .EQ. 1) GO TO 130

C     RDEQNS processes the input equations as follows:
C        o Reads the line and parses it into fields.
C        o Checks the equation for syntax.
C        o Stores the variable names from the equations.
C        o Puts the equation in postfix form.
C        o Adds the equation variables to a global list.
C     If any errors are found, that equation is ignored.
C     After all the equations have been read in, all the variables are
C     gathered into the /VAR../ arrays.  The assigned variables are
C     after the expression variables.

C     Sort the input variables (by ID)
C     SORTID gathers the variables of the specified type into
C     one area of an array and orders these variable
      ITIME = 1
      CALL SORTID ('T', NUMINP, ITIME, I)
      ICOBEG = ITIME + 1
      CALL SORTID ('C', NUMINP, ICOBEG, ICOEND)
      IGVBEG = ICOEND + 1
      CALL SORTID ('G', NUMINP, IGVBEG, IGVEND)
      INVBEG = IGVEND + 1
      CALL SORTID ('N', NUMINP, INVBEG, INVEND)
      IEVBEG = INVEND + 1
      CALL SORTID ('E', NUMINP, IEVBEG, IEVEND)

C     Set the ID to the order in which the LHS variables were defined
      NLHS = 1
      DO 100 I = MAXVAR, IXLHS, -1
         IDVAR(I) = NLHS
         NLHS = NLHS + 1
  100 CONTINUE

C     Sort deleted variables to end of entries
C     SORDEL sorts the deleted variables so that they appear at the start
C     of all non-deleted entries.
      CALL SORDEL (MAXVAR, IXLHS, I)
      JTIME = I + 1

C     Sort the LHS variables in the order defined
      CALL SORTID ('T', MAXVAR, JTIME, I)
      JGVBEG = I + 1
      CALL SORTID ('G', MAXVAR, JGVBEG, JGVEND)
      JNVBEG = JGVEND + 1
      CALL SORTID ('N', MAXVAR, JNVBEG, JNVEND)
      JEVBEG = JNVEND + 1
      CALL SORTID ('E', MAXVAR, JEVBEG, JEVEND)
      NVARGO = JGVEND - JGVBEG + 1
      NVARNO = JNVEND - JNVBEG + 1
      NVAREO = JEVEND - JEVBEG + 1

C     Link the variables with storage
C     Assign storage for variables
C     LNKSTO sets up the storage locations for all the variables.
C     Input and output variables of the same name share storage (unless
C     one is a history/global and the other is not).  Time and history/global
C     variables are all in the first storage location: time is in slot 1,
C     followed by the input history variables (if any), the input global
C     variables (if any), then the output only history/global variables.
      CALL LNKSTO (C(KNAMES+NAMLEN*(KNAMGV-1)), NUMSTO, LTMENT, IOERR)
      IF (IOERR .EQ. 1) GO TO 130

C     LNKFNC sets up the storage locations for the time functions that
C     need storage for results that must be saved over time steps.
      CALL LNKFNC (NUMSTO, *130)

C     Relink the equation variables with the sorted name array
      CALL LNKVAR (*130)

C     Check displacement variables
      IF ((NVARNP .GT. 0) .OR. (NVARNO .GT. 0)) THEN
C     CHKDIS finds the displacement variables.  The first two/three nodal
C     variables are displacement variables if and only if they begin with
C     'D' and end with the last character of the corresponding coordinate
C     name.
         CALL CHKDIS (NDIM, C(KNACOR), NVARNO, NAMVAR(JNVBEG),
     *    namlen, maxnam)
      END IF

C *************************************************************
C                   Open the Output Database
C *************************************************************
      CALL get_argument(2,FILNAM, LFIL)
      ndbout = excre(filnam(:lfil), EXCLOB, CPUWS, IOWS, IERR)
      IF (IERR .NE. 0) THEN
        SCRATCH = 'Problems creating database "'//FILNAM(:LFIL)//'".'
        CALL PRTERR ('FATAL', SCRATCH(:LENSTR(SCRATCH)))
        goto 130
      END IF
      OTOPEN = .TRUE.
      call exmxnm(ndbout, namlen, ierr)

C     RWEVAL reads the unread information from the input database,
C     processes the data for zoom mesh, and write the output database.

      CALL RWEVAL (NDBIN, NDBOUT, A, A, C, NPTIMS,
     &             NUMSTO, LTMENT, MAXSTK, NWRIT, IOERR, MERR)
      IF ((IOERR .EQ. 1) .OR. (MERR .EQ. 1)) GO TO 130

      if (numsto .gt. 1 .and. nsteps .eq. 0) then
         nsteps = 1
         nwrit = 1
      end if

      CALL MDSTAT (NERR, MEM)
      IF (NERR .GT. 0) THEN
         CALL MEMERR
      END IF

C     Converts a set of integer numbers into a consistent
C     set of strings of the same length (right justified)
      CALL INTSTR (1, 0, NWRIT, STR8, LSTR)
      WRITE (*, 10000) STR8(:LSTR)
10000 FORMAT (/, 4X, A,
     &   ' time steps have been written to the database')

  130 CONTINUE

      call mddel ('IDELB')
      CALL MDDEL ('NUMELB')
      CALL MDDEL ('VISELB')
      CALL MCDEL ('BLKTYP')
      CALL MDDEL ('SELELB')
      CALL MDDEL ('TIMES')
      CALL MDDEL ('IPTIMS')
      CALL MCDEL ('NAMECO')
      CALL MCDEL ('NAMES')
      CALL MDDEL ('ISEVOK')

      CALL MDSTAT (NERR, MEM)
      IF (NERR .GT. 0) THEN
         CALL MEMERR
      END IF

 150  continue
C     Exiting programs - close input/output files if they are open
C     or even if they opened and may have an error
      IF (INOPEN) CALL exclos(NDBIN, IERR)

      IF (OTOPEN) CALL exclos(NDBOUT, IERR)

C     Performs finishing details common to all programs.
C     Specifically, it gets and displays the CPU time used.

      call addlog (QAINFO(1)(:lenstr(QAINFO(1))))
      CALL WRAPUP (QAINFO(1))

      END