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 DBINAM (NDB, OPTION, NDIM, NELBLK, & NNDIM, NNELB, NVARHI, NVARGL, NVARNP, NVAREL, & NAMECO, NAMELB, VNAMES, IXHV, IXGV, IXNV, IXEV, & IA, KIEVOK, EXODUS, *) C======================================================================= C --*** DBINAM *** (EXOLIB) Read database names C -- Written by Amy Gilkey - revised 02/08/88 C -- C --DBINAM reads the names of the coordinates, the element block types, C --and the database variables from the database. All names are converted C --to uppercase and all embedded blanks within a name are removed. C --The element block variable truth table is also read. C -- C --Note that the numbers of variables are read in this routine. C -- C --This routine calls DBIV1 if the truth table is read. C -- C --This routine calls DBVINI and uses DBVIX to get the variable name C --indices. C -- C --Dynamic memory is reserved in this routine. If there is a problem, C --the routine returns normally without printing an error message. C -- C --Parameters: C -- NDB - IN - the database number C -- OPTION - IN - ' ' to not store, '*' to store all, else store options: C -- 'C' to store coordinate names C -- 'B' to store element block names C -- 'V' to store variables names C -- 'T' to store element block variable truth table C -- NDIM - IN - the number of coordinates per node C -- NELBLK - IN - the number of element blocks C -- NNDIM - OUT - the number of coordinates per node; <0 if end-of-file C -- NNELB - OUT - the number of element blocks; <0 if end-of-file C -- NVARHI - OUT - the number of history variables; <0 if end-of-file C -- NVARGL - OUT - the number of global variables; <0 if end-of-file C -- NVARNP - OUT - the number of nodal variables; <0 if end-of-file C -- NVAREL - OUT - the number of element variables; <0 if end-of-file C -- NAMECO - OUT - the names of the coordinates; max size = 6 (if OPTION) C -- NAMELB - OUT - the names of the element block types; max size = 256 C -- (if OPTION) C -- VNAMES - OUT - the names of the global, nodal, and element variables; C -- max size = 256 (if OPTION) C -- IXHV - OUT - the VNAMES index of the history variable names (if OPTION) C -- IXGV - OUT - the VNAMES index of the global variable names (if OPTION) C -- IXNV - OUT - the VNAMES index of the nodal variable names (if OPTION) C -- IXEV - OUT - the VNAMES index of the element variable names (if OPTION) C -- A - OUT - the dynamic memory base array C -- KIEVOK - OUT - the dynamic memory index of the element block variable C -- truth table; (if OPTION) C -- variable i of block j exists iff ISEVOK(j,i) C -- EXODUS - OUT - false if GENESIS file, true if EXODUS file so far C -- * - return statement if error encountered, including end-of-file; C -- NOT used if valid GENESIS file; message is printed C -- C --Database must be positioned in front of coordinate names upon entry; C --upon exit positioned after names. C --Routines Called: C -- EXUPCS - (SUPES) Convert to uppercase and blank non-standard C -- MDRSRV - (SUPES) Reserve dynamic memory C -- PCKSTR - (STRLIB) Remove embedded blanks PARAMETER (MAXDIM=6, MAXELB=512, MAXVAR=512) INTEGER NDB CHARACTER*(*) OPTION INTEGER NDIM, NELBLK INTEGER NNDIM, NNELB CHARACTER*8 NAMECO(*) CHARACTER*8 NAMELB(*) CHARACTER*8 VNAMES(*) INTEGER NVARHI, NVARGL, NVARNP, NVAREL INTEGER IXHV, IXGV, IXNV, IXEV INTEGER IA(*) INTEGER KIEVOK LOGICAL EXODUS CHARACTER*80 ERRMSG INTEGER LDUM EXODUS = .FALSE. NNDIM = -999 NNELB = -999 NVARHI = -999 NVARGL = -999 NVARNP = -999 NVAREL = -999 C --Read and pack coordinate names IF ((OPTION .EQ. '*') .OR. (INDEX (OPTION, 'C') .GT. 0)) THEN IF (NDIM .GT. MAXDIM) CALL PRTERR ('WARNING', & 'Too many coordinate names in the database') READ (NDB, END=160, ERR=170, IOSTAT=IERR) & (NAMECO(I), I=1,MIN(NDIM,MAXDIM)) DO 100 I = 1, MIN(NDIM,MAXDIM) CALL EXUPCS (NAMECO(I)) 100 CONTINUE CALL PCKSTR (MIN(NDIM,MAXDIM), NAMECO) ELSE READ (NDB, END=160, ERR=160, IOSTAT=IERR) END IF NNDIM = NDIM C --Read and pack element block type names IF ((OPTION .EQ. '*') .OR. (INDEX (OPTION, 'B') .GT. 0)) THEN IF (NELBLK .GT. MAXELB) CALL PRTERR ('WARNING', & 'Too many element block names in the database') READ (NDB, END=160, ERR=180, IOSTAT=IERR) & (NAMELB(I), I=1,MIN(NELBLK,MAXELB)) DO 110 I = 1, MIN(NELBLK,MAXELB) CALL EXUPCS (NAMELB(I)) 110 CONTINUE CALL PCKSTR (MIN(NELBLK,MAXELB), NAMELB) ELSE READ (NDB, END=160, ERR=180, IOSTAT=IERR) END IF NNELB = NELBLK C --Read the number of variables READ (NDB, END=160, ERR=190, IOSTAT=IERR) & NVARHI, NVARGL, NVARNP, NVAREL if ((nvarhi + nvargl + nvarnp + nvarel) .eq. 0) go to 160 EXODUS = .TRUE. C --Initialize for DBVTYP and DBVIX CALL DBVINI (NVARHI, NVARGL, NVARNP, NVAREL) IF ((OPTION .EQ. '*') .OR. (INDEX (OPTION, 'V') .GT. 0)) THEN IF (NVARHI + NVARGL + NVARNP + NVAREL .GT. MAXVAR) & CALL PRTERR ('WARNING', & 'Too many variable names in the database') C --Get the name indices CALL DBVIX ('H', 1, IXHV) CALL DBVIX ('H', NVARHI, IXHVE) IXHVE = MIN(IXHVE,MAXVAR) CALL DBVIX ('G', 1, IXGV) CALL DBVIX ('G', NVARGL, IXGVE) IXGVE = MIN(IXGVE,MAXVAR) CALL DBVIX ('N', 1, IXNV) CALL DBVIX ('N', NVARNP, IXNVE) IXNVE = MIN(IXNVE,MAXVAR) CALL DBVIX ('E', 1, IXEV) CALL DBVIX ('E', NVAREL, IXEVE) IXEVE = MIN(IXEVE,MAXVAR) C --Read and pack variable names READ (NDB, END=200, ERR=200, IOSTAT=IERR) & (VNAMES(I), I=IXHV,IXHVE), & (VNAMES(I), I=IXGV,IXGVE), & (VNAMES(I), I=IXNV,IXNVE), & (VNAMES(I), I=IXEV,IXEVE) DO 120 I = IXHV, IXHVE CALL EXUPCS (VNAMES(I)) 120 CONTINUE CALL PCKSTR (NVARHI, VNAMES(IXHV)) DO 130 I = IXGV, IXGVE CALL EXUPCS (VNAMES(I)) 130 CONTINUE CALL PCKSTR (NVARGL, VNAMES(IXGV)) DO 140 I = IXNV, IXNVE CALL EXUPCS (VNAMES(I)) 140 CONTINUE CALL PCKSTR (NVARNP, VNAMES(IXNV)) DO 150 I = IXEV, IXEVE CALL EXUPCS (VNAMES(I)) 150 CONTINUE CALL PCKSTR (NVAREL, VNAMES(IXEV)) ELSE READ (NDB, END=200, ERR=200, IOSTAT=IERR) END IF C --Read the element block variable truth table IF ((OPTION .EQ. '*') .OR. (INDEX (OPTION, 'T') .GT. 0)) THEN CALL MDRSRV ('ISEVOK', KIEVOK, NELBLK * NVAREL) CALL MDSTAT (NERR, MEM) IF (NERR .GT. 0) GOTO 160 CALL DBINM1 (NDB, OPTION, NELBLK, NVAREL, IA(KIEVOK), * IA(KIEVOK), IERR, MAX(NELBLK,1), *210) C --Call DBIV1 CALL DBIV1 (NELBLK, & NVARHI, NVARGL, NVARNP, NVAREL, IA(KIEVOK)) ELSE CALL DBINM1 (NDB, OPTION, NELBLK, NVAREL, LDUM, IDUM, & IERR, MAX(NELBLK,1), *210) END IF 160 CONTINUE RETURN 170 CONTINUE ERRMSG = 'COORDINATE NAMES' GOTO 220 180 CONTINUE ERRMSG = 'ELEMENT BLOCK NAMES' GOTO 220 190 CONTINUE ERRMSG = 'NUMBER OF VARIABLES' GOTO 220 200 CONTINUE ERRMSG = 'VARIABLE NAMES' GOTO 220 210 CONTINUE ERRMSG = 'ELEMENT BLOCK VARIABLE TRUTH TABLE' GOTO 220 220 CONTINUE CALL DBERR (IERR, ERRMSG) RETURN 1 END