lib
/
EXODUS
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
Cloned SEACAS for EXODUS library with extra build files for internal package management.
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
2 Commits
1 Branch
0 Tags
19 MiB
 
 
 
 
 
 
Tag: Branch: Tree: b1e2a11951
Branches Tags
${ item.name }
Create tag ${ searchTerm }
Create branch ${ searchTerm }
from 'b1e2a11951'
${ noResults }
EXODUS/packages/seacas/applications/grepos/grepos.f

1456 lines
46 KiB
Raw Blame History

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 GREPOS
C=======================================================================
C --*** GREPOS *** (GREPOS) GENESIS Positioning Program
C -- Written by Greg Sjaardema - revised 03/07/89
C -- Modified from GEN3D
C --
C --Expected input:
C -- o The commands on the standard input device.
C -- o The 3D GENESIS database on unit 9
C --
C --Output:
C -- o A listing of the input database information and any errors
C -- found on the standard output device.
C -- o The repositioned 3D GENESIS database on unit 10.
C --
C --Developed at Sandia National Laboratories.
C --
C --Current author and code sponsor: Greg Sjaardema
C --
C --Revision History:
C -- Modified from GEN3D [04/86 Created (Amy Gilkey)]
C --
C --Source is in FORTRAN 77
C --
C --External software used:
C -- SUPES package (dynamic memory, free-field reader, FORTRAN extensions)
C -- ExodusII library
C -- NetCDF library (with modified parameters)
C --
C --Documentation:
C -- none
include 'exodusII.inc'
include 'gp_namlen.blk'
include 'gp_progqa.blk'
include 'gp_dbase.blk'
include 'gp_dbtitl.blk'
include 'gp_dbnums.blk'
include 'gp_xyzoff.blk'
include 'gp_xyzrot.blk'
include 'gp_xyzmir.blk'
include 'gp_xyzwrp.blk'
include 'gp_nsset.blk'
include 'gp_smooth.blk'
include 'gp_snap.blk'
include 'gp_combine.blk'
include 'gp_deform.blk'
include 'gp_attrot.blk'
INCLUDE 'argparse.inc'
CHARACTER*2048 FILIN, FILOUT, SCRATCH, SYNTAX, HELP
CHARACTER*80 SCRSTR
C... String containing name of common element topology in model
C or 'MULTIPLE_TOPOLOGIES' if not common topology.
character*(MXSTLN) comtop
LOGICAL EXODUS, NONQUD, ALLONE, ORDER
LOGICAL SMOOTH, SWPSS, USRSUB, CENTRD
LOGICAL ISATRB, EXECUT, L64BIT
LOGICAL RENEL, DELEL, DELNP
INTEGER CMPSIZ, IOWS
integer goff, noff, eoff, moff, soff
DIMENSION A(1)
INTEGER IA(1)
LOGICAL LA(1)
EQUIVALENCE (A(1), IA(1))
EQUIVALENCE (A(1), LA(1))
CHARACTER*1 C(1)
C --A - the dynamic numeric memory base array
INCLUDE 'gp_qainfo.blk'
CALL STRTUP (QAINFO)
WRITE (*, 70)
CALL BANNER (0, QAINFO,
& 'A GENESIS DATABASE POSITIONING PROGRAM',
& ' ', ' ')
call cpyrgt (0, '1990')
CALL MDINIT (A)
CALL MCINIT (C)
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 40
C .. Get filename from command line. If not specified, emit error message
SYNTAX =
* 'Syntax is: "grepos [-name_length len] [-64] file_in file_out"'
HELP = 'Documentation: https://sandialabs.github.io' //
$ '/seacas-docs/sphinx/html/index.html#grepos'
NARG = argument_count()
if (narg .lt. 2) then
CALL PRTERR ('FATAL', 'Filenames not specified.')
CALL PRTERR ('CMDSPEC', SYNTAX(:LENSTR(SYNTAX)))
CALL PRTERR ('CMDSPEC', HELP(:LENSTR(HELP)))
GOTO 60
end if
C ... Parse options...
name_len = 0
l64bit = .false.
if (narg .gt. 2) then
iarg = 1
do
CALL get_argument(iarg,FILIN, LNAM)
if (filin(:lnam) .eq. '-name_length') then
CALL get_argument(iarg+1,FILIN, LNAM)
read (filin(:lnam), '(i10)') name_len
iarg = iarg + 2
else if (filin(:lnam) .eq. '-64') then
l64bit = .true.
iarg = iarg + 1
else
SCRATCH = 'Unrecognized command option "'//FILIN(:LNAM)//'"'
CALL PRTERR ('FATAL', SCRATCH(:LENSTR(SCRATCH)))
CALL PRTERR ('CMDSPEC', SYNTAX(:LENSTR(SYNTAX)))
CALL PRTERR ('CMDSPEC', HELP(:LENSTR(HELP)))
end if
if (iarg .gt. narg-2) exit
end do
end if
C --Open the input database and read the initial variables
NDBIN = 9
NDBOUT = 10
CMPSIZ = 0
IOWS = 0
FILIN = ' '
CALL get_argument(narg-1,FILIN, LNAM)
FILOUT = ' '
CALL get_argument(narg,FILOUT, LFIL)
if (filin .eq. filout) then
CALL PRTERR ('FATAL',
$ 'Input and Output filename are the same. Not allowed')
goto 60
endif
NDBIN = exopen(filin(:lnam), EXREAD, CMPSIZ, IOWS, vers, IERR)
IF (IERR .NE. 0) THEN
SCRATCH = 'Database "'//FILIN(:LNAM)//'" does not exist.'
CALL PRTERR ('FATAL', SCRATCH(:LENSTR(SCRATCH)))
GOTO 60
END IF
call exgini(ndbin, title, ndim, numnp, numel, nelblk,
* numnps, numess, ierr)
if (numnps .gt. 0) then
call exinq(ndbin, EXNSNL, lnpsnl, rdum, cdum, ierr)
call exinq(ndbin, EXNSDF, lnpsdf, rdum, cdum, ierr)
else
lnpsnl = 0
lnpsdf = 0
end if
if (numess .gt. 0) then
call exinq(ndbin, EXSSEL, lessel, rdum, cdum, ierr)
call exinq(ndbin, EXSSDF, lessdf, rdum, cdum, ierr)
else
lessel = 0
lessdf = 0
end if
call exinq(ndbin, EXDBMXUSNM, namlen, rdum, cdum, ierr)
if (name_len .eq. 0) then
if (namlen < 32) namlen = 32
if (namlen .gt. mxname) then
namlen = mxname
maxnam = mxname
else
maxnam = namlen
end if
else
C ... Use user-specified length
namlen = name_len
maxnam = name_len
end if
call exmxnm(ndbin, namlen, ierr)
C --Reserve memory for the input information
CALL MDRSRV ('XN', KXN, NUMNP)
IF (NDIM .GE. 2) THEN
CALL MDRSRV ('YN', KYN, NUMNP)
END IF
IF (NDIM .EQ. 3) THEN
CALL MDRSRV ('ZN', KZN, NUMNP)
ELSE
CALL MDRSRV ('ZN', KZN, 1)
END IF
CALL MDRSRV ('MAPNN', KMAPNN, NUMNP)
CALL MDRSRV ('MAPEL', KMAPEL, NUMEL)
CALL MDRSRV ('ATRIB', KATRIB, 0)
CALL MDRSRV ('LINK', KLINK, 0)
CALL MDRSRV ('IDELB', KIDELB, NELBLK)
CALL MDRSRV ('IDELB2', KIDELB2,NELBLK)
CALL MDRSRV ('NUMELB', KNELB, NELBLK)
CALL MDRSRV ('NUMLNK', KNLNK, NELBLK)
CALL MDRSRV ('NUMATR', KNATR, NELBLK)
CALL MCRSRV ('BLKTYP', KBKTYP, MXSTLN*NELBLK)
CALL MCRSRV ('NAMEEB', KNAMEB, maxnam*NELBLK)
CALL MDRSRV ('IDNPS', KIDNS, NUMNPS)
CALL MDRSRV ('NNNPS', KNNNS, NUMNPS)
CALL MDRSRV ('NDNPS', KNDNPS, NUMNPS)
CALL MDRSRV ('IXNNPS', KIXNNS, NUMNPS)
CALL MDRSRV ('IXDNPS', KIXDNS, NUMNPS)
CALL MDRSRV ('LTNNPS', KLTNNS, LNPSNL)
CALL MDRSRV ('FACNPS', KFACNS, LNPSDF)
CALL MCRSRV ('NAMENP', KNAMNP, maxnam*NUMNPS)
CALL MDRSRV ('IDESS', KIDSS, NUMESS)
CALL MDRSRV ('NEESS', KNESS, NUMESS)
CALL MDRSRV ('NDESS', KNDSS, NUMESS)
CALL MDRSRV ('IXEESS', KIXESS, NUMESS)
CALL MDRSRV ('IXDESS', KIXDSS, NUMESS)
CALL MDRSRV ('LTEESS', KLTESS, LESSEL)
CALL MDRSRV ('LTSESS', KLTSSS, LESSEL)
CALL MDRSRV ('LTSSNC', KLTSNC, LESSEL)
CALL MDRSRV ('FACESS', KFACSS, LESSDF)
CALL MCRSRV ('NAMESS', KNAMSS, maxnam*NUMESS)
CALL MCRSRV ('NAMECO', KNAMCO, maxnam*ndim)
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 40
C --Read information from the database and close file
call exgcor (ndbin, a(kxn), a(kyn), a(kzn), ierr)
call exopts (0, ierr)
call exgnnm (ndbin, ia(kmapnn), ierr)
call exgenm (ndbin, ia(kmapel), ierr)
call exopts (EXVRBS, ierr)
call getcon (ndbin, ndim, C(knamco), ierr)
CALL DBIELB (NDBIN, '*', 1, NELBLK,
& IA(KIDELB), IA(KNELB), IA(KNLNK), IA(KNATR),
& A(1), IA(1), KLINK, KATRIB, C(KBKTYP),
* numatt, *60)
call CHKTOP(NELBLK, C(KBKTYP), COMTOP)
call getnam(NDBIN, 1, nelblk, C(KNAMEB))
C ... Save original element block ids in case the user changes them
C Needed when reading/writing element variables.
call cpyid(nelblk, ia(kidelb), ia(kidelb2))
C ... Attribute names...
call mcrsrv('NAMATT', KNAMATT, maxnam*NUMATT)
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 40
call getattnam(ndbin, nelblk, ia(kidelb), ia(knatr), c(knamatt))
if (numnps .gt. 0) then
call exgcns(ndbin, ia(kidns), ia(knnns), ia(kndnps),
& ia(kixnns), ia(kixdns), ia(kltnns), a(kfacns), ierr)
call getnam(NDBIN, 2, numnps, C(KNAMNP))
end if
if (numess .gt. 0) then
call getss(ndbin, numess, ia(kidss), ia(kness), ia(kndss),
& ia(kixess), ia(kixdss), ia(kltess), ia(kltsss),
& ia(kltsnc), kfacss, a, allone, lessdf, *50)
call getnam(NDBIN, 3, numess, C(KNAMSS))
end if
EXODUS = .TRUE.
call exinq(ndbin, EXQA, nqarec, rdum, cdum, ierr)
call exinq(ndbin, EXINFO, ninfo, rdum, cdum, ierr)
call mcrsrv('QAREC', kqarec, (nqarec+1) * 4 * MXSTLN)
call mcrsrv('INFREC', kinfo, (ninfo+2) * MXLNLN)
CALL MCSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 40
if (nqarec .gt. 0) then
C ... Wrapper to get strings the right length
call exgqaw(ndbin, c(kqarec), ierr)
end if
if (ninfo .gt. 0) then
C ... Wrapper to get info record the right length
call exginw(ndbin, c(kinfo), ierr)
end if
C --Read the database time steps
c determine how many time steps are stored
call exinq (ndbin, EXTIMS, NSTEPS, rdum, cdum, ierr)
call mdrsrv('TIMES', KTIMES, NSTEPS)
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 40
c read time values at all time steps
if (nsteps .gt. 0) then
call exgatm (ndbin, a(ktimes), ierr)
end if
exodus = (nsteps .gt. 0)
IF (EXODUS) THEN
CALL DBINAM (NDBIN, '*', NDIM, NELBLK, NUMNPS, NUMESS,
& NNDIM, NNELB, NVARGL, NVARNP, NVAREL, NVARNS, NVARSS,
& IXGV, IXNV, IXEV, IXNSV, IXSSV,
& A, IA, KIEVOK, KNSVOK, KSSVOK, C, KNAMES, EXODUS, *40)
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 40
ELSE
nvargl = 0
nvarnp = 0
nvarel = 0
nvarns = 0
nvarss = 0
ixgv = 0
ixnv = 0
ixev = 0
ixnsv = 0
ixssv = 0
kievok = 0
knsvok = 0
kssvok = 0
knames = 0
END IF
CALL DBPINI ('NTISV', NDBIN, TITLE, NDIM, NUMNP, NUMEL, NELBLK,
& NUMNPS, LNPSNL, LNPSDF, NUMESS, LESSEL,
& LESSDF, NVARGL, NVARNP, NVAREL, NVARNS, NVARSS, FILIN)
C --Read in runtime parameters
C --Reserve memory for offsets
MBLK = MAX(NELBLK, NUMNPS)
CALL MDRSRV ('XEXPL', KXEXPL, MBLK)
IF (NDIM .GE. 2) THEN
CALL MDRSRV ('YEXPL', KYEXPL, MBLK)
ELSE
CALL MDRSRV ('YEXPL', KYEXPL, 1)
END IF
IF (NDIM .EQ. 3) THEN
CALL MDRSRV ('ZEXPL', KZEXPL, MBLK)
ELSE
CALL MDRSRV ('ZEXPL', KZEXPL, 1)
END IF
C -- Reserve memory for node equiv (equiv node X with Y handled in command)
call mdrsrv ('IXNP', KIXNP, NUMNP)
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 40
C .. ISATRB is TRUE if the model contains attributes
CALL MDFIND('ATRIB', KATRIB, KALEN)
ISATRB = (KALEN .NE. 0)
C .. Allocate memory for attribute scaling
CALL CNTATR(NELBLK, IA(KNATR), IATCNT)
CALL MDRSRV('ATRSCL', KATRSC, 2*IATCNT)
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 40
C .. Set up status arrays for user manipulation of element blocks and sets
CALL MDRSRV ('IELBST', KIELBS, NELBLK)
CALL MDRSRV ('INPSST', KINPSS, NUMNPS)
CALL MDRSRV ('IESSST', KIESSS, NUMESS)
CALL MDRSRV ('ITIMST', KITIMS, NSTEPS)
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 40
C .. Set up status arrays for element to nodal variable conversion
call mdrsrv ('INOD2EL', KINOD2EL, NVARNP)
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 40
25 CONTINUE
goff = 0
noff = goff + (nvargl * maxnam)
eoff = noff + (nvarnp * maxnam)
moff = eoff + (nvarel * maxnam)
soff = moff + (nvarns * maxnam)
CALL COMAND (NDBIN, EXECUT,
& IA(KIDELB), IA(KNELB), IA(KNLNK), IA(KNATR),
& IA(KIDNS), IA(KNNNS), IA(KNDNPS),IA(KIXNNS),IA(KIXDNS),
$ IA(KLTNNS), A(KFACNS),
& IA(KIDSS), IA(KNESS), IA(KNDSS), IA(KIXESS), IA(KIXDSS),
& IA(KLTESS), IA(KLTSSS), A(KFACSS),
& A(KXN), A(KYN), A(KZN),
& A(KXEXPL), A(KYEXPL), A(KZEXPL), MODBLK,
& ISATRB, A(KATRSC), IA(KIXNP), IA(KMAPNN), IA(KMAPEL),
& IA(KIELBS), IA(KINPSS), IA(KIESSS),
& NQAREC, C(KQAREC), NINFO, c(kinfo), c(kbktyp),
* c(knameb), c(knamnp), c(knamss), c(knamatt),
& c(knames+goff), nvargl, c(knames+noff), nvarnp,
& c(knames+eoff), nvarel, c(knames+moff), nvarns,
* c(knames+soff), nvarss, IA(KINOD2EL),
& SWPSS, SMOOTH, USRSUB, CENTRD,
& NSTEPS, A(KTIMES), IA(KITIMS), A, IA, *60)
C ... Snap
if (numsnp .gt. 0) then
call mdrsrv('ssblk', issblk, nelblk)
call mdrsrv('iscrn', iscrnp, numnp)
call mdrsrv('iscre', iscrep, numel)
do 30 i=1, numsnp
if (ismtyp(i) .eq. ISNAP) then
call snap(ndbin, a, ia, i, a(kxn), a(kyn), a(kzn), ndim,
* numnp, numess, ia(kidss), ia(kness), ia(kixess),
* nelblk, ia(kidelb), ia(knelb), ia(knlnk))
else
call move(ndbin, a, ia, i, a(kxn), a(kyn), a(kzn), ndim,
* numnp, numel, numess, ia(kidss), ia(kness), ia(kixess),
* ia(kltess),
* nelblk, ia(kidelb), ia(knelb), ia(knlnk), ia(klink),
* ia(issblk), ia(iscrnp), ia(iscrep))
end if
30 continue
call mddel('ssblk')
call mddel('iscrn')
call mddel('iscre')
end if
C ... Warp
if (iwarp .ne. 0) then
if (ndim .ne. 3) then
CALL PRTERR('PROGRAM',
* 'Warp cannot be specified for 2D databases')
else
call wrpxyz(a(kxn), a(kyn), a(kzn), numnp,
* iwarp, nrmwrp, wrpdis)
end if
end if
C --Get the new positions for the elements and nodes
IF (XMIRR * YMIRR * ZMIRR .LT. 0.0) THEN
CALL DBMIRR (1, NELBLK, IA(KIDELB), IA(KNELB), IA(KNLNK),
* IA(KLINK), c(kbktyp), NDIM, NONQUD)
CALL MDRSRV ('iblock', kiblock, nelblk)
call chkss(nelblk, ia(knelb), ia(kiblock))
CALL MIRSS (IA(KIDSS), IA(KNESS),
* IA(KIXESS), IA(KLTESS),
* IA(KLTSSS),
* IA(KIBLOCK), c(kbktyp), ALLONE, COMTOP)
call mddel('iblock')
END IF
C ... Swaps the orientation of a sideset. Should only be used on shells...
IF (SWPSS) THEN
CALL SWPESS (NUMESS, IA(KIDSS), IA(KNESS), IA(KNDSS),
* IA(KIXESS), IA(KIXDSS), IA(KLTESS),
* IA(KLTSSS), IA(KLTSNC), A(KFACSS), ALLONE, NONQUD,
* COMTOP)
END IF
IF (USRSUB) THEN
CALL MDRSRV ('XNEW', kxnew, numnp)
CALL MDRSRV ('YNEW', kynew, numnp)
if (ndim .eq. 3) then
CALL MDRSRV ('ZNEW', kznew, numnp)
else
CALL MDRSRV ('ZNEW', kznew, 1)
end if
CALL XYZMOD (numnp, ndim, A(KXN), A(KYN), A(KZN),
* A(KXNEW), A(KYNEW), A(KZNEW))
CALL CPYREA(NUMNP, A(KXNEW), A(KXN))
CALL CPYREA(NUMNP, A(KYNEW), A(KYN))
if (ndim .eq. 3) CALL CPYREA(NUMNP, A(KZNEW), A(KZN))
CALL MDDEL ('XNEW')
CALL MDDEL ('YNEW')
CALL MDDEL ('ZNEW')
END IF
CALL NEWXYZ (A(KXN), A(KYN), A(KZN), NUMNP, NDIM, A)
C --Offset or scale each block if specified (EXPLODE, SCALE BLOCK)
C -- MODBLK = 1 if block explode
C -- MODBLK = 2 if block scale
C -- MODBLK = 3 if block randomize
IF (MODBLK .EQ. 1 .OR. MODBLK .EQ. 2 .OR. MODBLK .EQ. 3) THEN
CALL MDRSRV ('ICONOD', KICOND, NELBLK*NUMNP)
CALL MDRSRV ('MATMAP', KMTMAP, NELBLK*NELBLK)
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 40
CALL EXPXYZ (A(KXN), A(KYN), A(KZN), IA(KICOND),
& A(KXEXPL), A(KYEXPL), A(KZEXPL), IA(KMTMAP),
& NELBLK, IA(KIDELB), IA(KNELB), IA(KNLNK), IA(KLINK),
& NUMNP, NDIM, MODBLK)
END IF
C -- MODBLK = 4 if nodeset randomize
IF (MODBLK .EQ. 4) THEN
CALL EXPXYZN (A(KXN), A(KYN), A(KZN),
& A(KXEXPL), A(KYEXPL), A(KZEXPL),
& NUMNPS, IA(KIDNS), IA(KNNNS), IA(KIXNNS), IA(KLTNNS),
& NUMNP, NDIM, MODBLK)
END IF
C ... Deform
if (idefst .gt. 0) then
if (.not. exodus) then
CALL PRTERR ('FATAL',
* 'Deform command requires displacements.')
GOTO 60
end if
if (nsteps .lt. idefst) then
CALL PRTERR ('FATAL',
* 'Deformation step is larger than database step count.')
GOTO 60
end if
if (nvarnp .lt. ndim) then
CALL PRTERR ('FATAL',
* 'There are not enough nodal displacement variables.')
GOTO 60
end if
call mdrsrv('DISPX', kdispx, numnp)
call mdrsrv('DISPY', kdispy, numnp)
call mdrsrv('DISPZ', kdispz, numnp)
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 40
call deform(a(kxn), a(kyn), a(kzn), numnp, ndim,
* a(kdispx), a(kdispy), a(kdispz), ndbin, idefst)
call mddel('DISPX')
call mddel('DISPY')
call mddel('DISPZ')
end if
C ... Scale the attributes
IF (ISATRB) THEN
CALL NEWATR (NELBLK, IA(KNATR), A(KATRSC), IA(KNELB),
& A(KATRIB))
END IF
IF (REVATT) THEN
CALL ROTATR (NELBLK, NDIM, IA(KIDELB), C(KBKTYP), IA(KNATR),
* IA(KNELB), A(KATRIB))
END IF
IF (SMOOTH) THEN
call mdrsrv ('COSIN', ICOSIN, numnp * ndim)
call mdrsrv ('NODES', inodes, numnp)
call mdrsrv ('ISBND', iisbnd, numnp)
call dobnd (a(kxn), a(kyn), a(kzn), ia(knelb), ia(knlnk),
& ia(kidelb), ia(klink), a(icosin), ia(inodes), ia(iisbnd),
& numnp, ndim, nelblk)
call mddel('COSIN')
call mdrsrv('XSCR', ixscr, numnp)
call mdrsrv('YSCR', iyscr, numnp)
if (ndim .eq. 3) then
call mdrsrv('ZSCR', izscr, numnp)
else
izscr = 1
end if
call smogs (a(kxn), a(kyn), a(kzn), ia(knelb), ia(knlnk),
& ia(kidelb), ia(klink), ia(iisbnd), nelblk, numnp,
& nit, toler, r0,
& a(ixscr), a(iyscr), a(izscr), ia(inodes), ndim)
END IF
C ... Incremental execution mode (re-enter COMAND routine)
C ... NOTE: the code from 'CALL COMAND' to here can be reexecuted.
C if MDRSRV or MDDEL is called, make sure it can be run
C multiple times.
if (execut) go to 25
C ... Calculate centroid if requested...
if (centrd) then
if (exodus) then
CALL PRTERR ('FATAL',
* 'Centroid function does not work for exodus databases yet.')
GOTO 60
end if
call mdrsrv ('CENTROID', KCENT, NDIM*NUMEL)
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 40
call centroid(a(kxn), a(kyn), a(kzn),
* a(kcent), a(kcent+numel), a(kcent+2*numel), nelblk,
* ia(knelb), ia(knlnk), ia(klink), ndim)
end if
C ... See if node equivalencing specified
DELNP = .FALSE.
if (equiv) then
if (eqtoler .ge. 0.0) then
call mdrsrv ('IX', KIX, NUMNP)
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 40
call matxyz(ndim, numnp, a(kxn), a(kyn), a(kzn), ia(kix),
& ia(kixnp), nmatch, eqtoler)
CALL MDDEL('IX')
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 40
else
nmatch = 0
do i=1, numnp
if (ia(kixnp+i-1) .ne. i) nmatch = nmatch+1
end do
end if
write (*,*) 'Equivalencing ', nmatch, ' nodes'
DELNP = (NMATCH .NE. 0)
end if
C --"Munch" the element blocks
C ... Save old counts that are needed for writing timesteps
numel0 = numel
nelblk0 = nelblk
numnp0 = numnp
C --location of original numelb, isevok arrays
kidelb0 = kidelb2
knelb0 = knelb
kievok0 = kievok
I = INTCNT (0, IA(KIELBS), NELBLK)
RENEL = (I .LT. NELBLK)
NUMEL1 = NUMEL
if (renel .or. delnp) then
CALL MDRSRV ('MSCR', KMSCR, MAX(NUMEL0, NUMNP0))
if (exodus) then
C ... Map from new var to old for mapping variables.
CALL MDRSRV ('MAPL', KMAPL, NUMEL0)
CALL MDRSRV ('MAPN', KMAPN, NUMNP0)
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 40
CALL INIMAP(NUMEL0, IA(KMAPL))
CALL INIMAP(NUMNP0, IA(KMAPN))
end if
end if
IF (RENEL) THEN
C ... Reserve space for original NUMELB and ISEVOK arrays and copy
C old array contents into new (Only needed if EXODUS)
IF (EXODUS) THEN
CALL MDRSRV ('NUMELB0', KNELB0, NELBLK0)
CALL MDRSRV ('IDELB0', KIDELB0, NELBLK0)
CALL MDFIND ('ISEVOK', IDUM, LIEVOK)
CALL MDRSRV ('ISEVOK0', KIEVOK0, LIEVOK)
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 40
CALL CPYINT (NELBLK0, IA(KNELB), IA(KNELB0))
CALL CPYINT (NELBLK0, IA(KIDELB2), IA(KIDELB0))
CALL CPYINT (LIEVOK, IA(KIEVOK), IA(KIEVOK0))
END IF
CALL MDRSRV ('IXEL', KIXEL, NUMEL)
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 40
CALL MDFIND ('LINK', IDUM, LLNK)
CALL MDRSRV ('LINKO', KLINKO, LLNK)
CALL MDFIND ('ATRIB', IDUM, LATR)
CALL MDRSRV ('ATRIBO', KATRO, LATR)
CALL MDRSRV ('IXELB', KIXELB, NELBLK)
CALL MDRSRV ('JNELB', KJNELB, NELBLK)
CALL MDRSRV ('ISCR', KISCR, NELBLK)
CALL MCRSRV ('NAMSCR', KNMSC, maxnam*NELBLK)
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 40
C ... NUMEL changed in this block (if elements deleted)
CALL MUNELB (NELBLK, IA(KIELBS), NUMEL,
& IA(KIDELB), IA(KNELB), IA(KNLNK), IA(KNATR),
& IA(KLINK), A(KATRIB), IA(KLINKO), A(KATRO),
& IA(KIXEL), IA(KIXELB), IA(KJNELB), IA(KISCR),
& c(kbktyp), c(knmsc), LLINK, LATRIB, c(knamatt),
* c(knameb))
C ... Fix up the truth table if the element block count changes...
if (exodus .and. nvarel .gt. 0 .and. nelblk .ne. nelblk0) then
call muntt(nelblk0, nelblk, nvarel,
$ ia(kievok0), ia(kievok), ia(kielbs))
end if
CALL MDDEL ('LINKO')
CALL MDDEL ('ATRIBO')
CALL MDDEL ('IXELB')
CALL MDDEL ('JNELB')
CALL MDDEL ('ISCR')
CALL MCDEL ('NAMSCR')
CALL MDLONG('LINK', KLINK, LLINK)
CALL MDLONG('ATRIB', KATRIB, LATRIB)
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 40
END IF
CALL MDDEL ('IELBST')
C --Mark if any elements are deleted
DELEL = NUMEL .LT. NUMEL1
IF (DELEL) THEN
C --Make up an index of nodes in the existing element blocks
N = NUMNP
CALL ZMFIXD (NELBLK, IA(KNELB), IA(KNLNK), IA(KLINK),
* N, IA(KIXNP))
DELNP = (N .LT. NUMNP)
END IF
C --Squeeze the coordinates
IF (DELNP) THEN
C ... NUMNP modified in this call
CALL ZMXYZ (NDIM, NUMNP, IA(KIXNP), A(KXN), A(KYN), A(KZN))
CALL MDLONG ('XN', KXN, NUMNP)
CALL MDLONG ('YN', KYN, NUMNP)
IF (NDIM .EQ. 3) THEN
CALL MDLONG ('ZN', KZN, NUMNP)
END IF
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 40
CALL REMAP(NUMNP0, IA(KIXNP), IA(KMAPNN), IA(KMSCR))
IF (EXODUS) THEN
CALL REMAP (NUMNP0, IA(KIXNP), IA(KMAPN), IA(KMSCR))
END IF
END IF
C --Renumber the element map
IF (RENEL) THEN
CALL REMAP (NUMEL0, IA(KIXEL), IA(KMAPEL), IA(KMSCR))
IF (EXODUS) THEN
CALL REMAP (NUMEL0, IA(KIXEL), IA(KMAPL), IA(KMSCR))
END IF
END IF
C --Squeeze the element map
IF (DELEL) THEN
C ... Changes first argument
CALL ZMMAP (NUMEL0, IA(KMAPEL))
CALL MDLONG ('MAPEL', KMAPEL, NUMEL)
IF (EXODUS) THEN
CALL ZMMAP (NUMEL0, IA(KMAPL))
CALL MDLONG ('MAPL', KMAPL, NUMEL)
END IF
END IF
C --Renumber the element block nodes
IF (DELNP) THEN
CALL ZMMAP(NUMNP0, IA(KMAPNN))
CALL MDLONG ('MAPNN', KMAPNN, NUMNP)
CALL RENELB (NELBLK, -999, IA(KIXNP),
& IA(KNELB), IA(KNLNK), IA(KLINK))
END IF
C --Renumber the nodal point set nodes
IF (DELNP) THEN
CALL RENIX (LNPSNL, -999, IA(KIXNP), IA(KLTNNS), .TRUE.)
END IF
C --Renumber the element side set elements
IF (RENEL) THEN
CALL RENIX (LESSEL, -999, IA(KIXEL), IA(KLTESS), .TRUE.)
END IF
IF (RENEL) THEN
CALL MDDEL ('IXEL')
END IF
C --"Munch" the nodal point sets
I = INTCNT (0, IA(KINPSS), NUMNPS)
NUMNPS0 = NUMNPS
KIDNS0 = KIDNS
KNNNS0 = KNNNS
LNPSNL0 = LNPSNL
KNSVOK0 = KNSVOK
IF ((I .LT. NUMNPS) .OR. DELNP) THEN
CALL MDRSRV ('LTNNPO', KLTNNO, LNPSNL)
CALL MDRSRV ('FACNPO', KFACNO, LNPSNL)
CALL MDRSRV ('IXNNPO', KIXNNO, NUMNPS)
CALL MDRSRV ('NNNPO', KNNNO, NUMNPS)
CALL MDRSRV ('ISCR', KISCR, NUMNPS)
CALL MDRSRV ('IDNS0', KIDNS0, NUMNPS0)
CALL MDRSRV ('NNNPS0', KNNNS0, NUMNPS0)
CALL MCRSRV ('NAMSCR', KNMSC, maxnam*NUMNPS)
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 40
CALL CPYINT (NUMNPS0, IA(KIDNS), IA(KIDNS0))
CALL CPYINT (NUMNPS0, IA(KNNNS), IA(KNNNS0))
CALL MUNNPS (NUMNPS, IA(KINPSS), LNPSNL, LNPSDF,
& IA(KIDNS), IA(KNNNS), IA(KIXNNS), IA(KLTNNS), A(KFACNS),
& IA(KLTNNO), A(KFACNO), IA(KIXNNO), IA(KNNNO), IA(KISCR),
* C(KNMSC), C(KNAMNP))
CALL MDDEL ('LTNNPO')
CALL MDDEL ('FACNPO')
CALL MDDEL ('IXNNPO')
CALL MDDEL ('NNNPO')
CALL MDDEL ('ISCR')
CALL MCDEL ('NAMSCR')
C --Squeeze the nodal point sets
IF (DELNP) THEN
CALL ZMNPS (NUMNPS, IA(KINPSS), LNPSNL, LNPSDF,
* IA(KIDNS), IA(KNNNS), IA(KIXNNS), IA(KLTNNS), A(KFACNS),
* C(KNAMNP))
END IF
C ... Fix up the truth table if the nodeset count changes...
if (exodus .and. nvarns .gt. 0 .and. numnps .ne. numnps0) then
CALL MDFIND ('ISNSVOK', IDUM, LNSVOK)
CALL MDRSRV ('ISNSVOK0', KNSVOK0, LNSVOK)
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 40
CALL CPYINT (LNSVOK, IA(KNSVOK), IA(KNSVOK0))
call muntt(numnps0, numnps, nvarns,
$ ia(knsvok0), ia(knsvok), ia(kinpss))
C ... check that the nodesets that are retained contain the same number
C of nodes that the original nodesets contain. At the current time,
C can only map nodeset variables if the nodesets are the same...
i1 = 0
do i=0,numnps0-1
if (ia(kinpss+i) .eq.0) then
if (IA(KNNNS0+i) .ne. IA(KNNNS+i1)) then
write (*,900) 'Nodeset', ia(kidns0+i)
end if
i1 = i1 + 1
end if
end do
end if
CALL MDLONG ('IDNPS', KIDNS, NUMNPS)
CALL MDLONG ('NNNPS', KNNNS, NUMNPS)
CALL MDLONG ('IXNNPS', KIXNNS, NUMNPS)
CALL MDLONG ('LTNNPS', KLTNNS, LNPSNL)
CALL MDLONG ('FACNPS', KFACNS, LNPSDF)
END IF
CALL MDDEL ('INPSST')
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 40
C --"Munch" the element side sets
I = INTCNT (0, IA(KIESSS), NUMESS)
NUMESS0 = NUMESS
KIDSS0 = KIDSS
KNESS0 = KNESS
LESSEL0 = LESSEL
KSSVOK0 = KSSVOK
IF ((I .LT. NUMESS) .OR. DELEL) THEN
CALL MDRSRV ('LTEESO', KLTESO, LESSEL)
CALL MDRSRV ('LTSSO', KLTSSO, LESSEL)
CALL MDRSRV ('FACS0', KFACS0, LESSDF)
CALL MDRSRV ('IXEESO', KIXESO, NUMESS)
CALL MDRSRV ('IXEDS0', KIXDS0, NUMESS)
CALL MDRSRV ('NEESO', KNESO, NUMESS)
CALL MDRSRV ('NEDS0', KNDS0, NUMESS)
CALL MDRSRV ('ISCR', KISCR, NUMESS)
CALL MDRSRV ('IDSS0', KIDSS0, NUMESS0)
CALL MDRSRV ('NEESS0', KNESS0, NUMESS0)
CALL MCRSRV ('NAMSCR', KNMSC, maxnam*NUMESS)
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 40
CALL CPYINT (NUMESS0, IA(KIDSS), IA(KIDSS0))
CALL CPYINT (NUMESS0, IA(KNESS), IA(KNESS0))
CALL MUNESS (NUMESS, IA(KIESSS), LESSEL, LESSDF,
& IA(KIDSS), IA(KNESS), IA(KNDSS), IA(KIXESS), IA(KIXDSS),
& IA(KLTESS), IA(KLTSSS), A(KFACSS),
& IA(KLTESO), IA(KLTSSO), A(KFACS0), IA(KIXESO), IA(KIXDS0),
& IA(KNESO), IA(KNDS0), IA(KISCR), C(KNMSC), C(KNAMSS))
CALL MDDEL ('LTEESO')
CALL MDDEL ('LTSSO')
CALL MDDEL ('FACS0')
CALL MDDEL ('IXEESO')
CALL MDDEL ('IXEDS0')
CALL MDDEL ('NEESO')
CALL MDDEL ('NEDS0')
CALL MDDEL ('ISCR')
CALL MCDEL ('NAMSCR')
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 40
C --Squeeze the element side sets
IF (DELEL) THEN
CALL ZMESS (NUMESS, ia(kiesss), LESSEL, LESSDF,
& IA(KIDSS), IA(KNESS), IA(KNDSS), IA(KIXESS),
* IA(KIXDSS), IA(KLTESS), IA(KLTSSS), IA(KLTSNC), A(KFACSS),
* C(KNAMSS))
END IF
C ... Fix up the truth table if the sideset count changes...
if (exodus .and. nvarss .gt. 0 .and. numess .ne. numess0) then
CALL MDFIND ('ISSSVOK', IDUM, LSSVOK)
CALL MDRSRV ('ISSSVOK0', KSSVOK0, LSSVOK)
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 40
call cpyint(lssvok, ia(kssvok),ia(kssvok0))
call muntt(numess0, numess, nvarss,
$ ia(kssvok0), ia(kssvok), ia(kiesss))
C ... check that the sidesets that are retained contain the same number
C of faces that the original sidesets contain. At the current time,
C can only map sideset variables if the sidesets are the same...
i1 = 0
do i=0,numess0-1
if (ia(kiesss+i) .eq.0) then
if (IA(KNESS0+i) .ne. IA(KNESS+i1)) then
write (*,900) 'Sideset', ia(kidss0+i)
end if
i1 = i1 + 1
end if
end do
end if
CALL MDLONG ('IDESS', KIDSS, NUMESS)
CALL MDLONG ('NEESS', KNESS, NUMESS)
CALL MDLONG ('IXEESS', KIXESS, NUMESS)
CALL MDLONG ('LTEESS', KLTESS, LESSEL)
CALL MDLONG ('LTSESS', KLTSSS, LESSEL)
CALL MDLONG ('FACESS', KFACSS, LESSDF)
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 40
END IF
CALL MDDEL ('IESSST')
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 40
CALL MDDEL ('IXNP')
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 40
CALL MINMAX (NUMNP, A(KXN), XMIN, XMAX)
CALL MINMAX (NUMNP, A(KYN), YMIN, YMAX)
IF (NDIM .EQ. 3) THEN
CALL MINMAX (NUMNP, A(KZN), ZMIN, ZMAX)
END IF
call limits('Output Mesh Limits:', ndim,
& xmin, xmax, ymin, ymax, zmin, zmax)
C --Open the output database
CMPSIZ = 0
IOWS = iowdsz()
MODE = EXCLOB
if (l64bit) then
MODE = MODE + EX_ALL_INT64_DB + EX_ALL_INT64_API
end if
ndbout = excre(filout(:lfil), MODE, CMPSIZ, IOWS, IERR)
if (ierr .lt. 0) then
call exopts (EXVRBS, ierr1)
call exerr('grepos', 'Error from excre', ierr)
go to 50
endif
call exmxnm(ndbout, maxnam, ierr)
if (l64bit) then
C ... Compress the output
call exsetopt(ndbout, EX_OPT_COMPRESSION_LEVEL, 1, ierr)
call exsetopt(ndbout, EX_OPT_COMPRESSION_SHUFFLE, 1, ierr)
end if
C --Write the QA records
CALL DBOQA (NDBOUT, QAINFO, NQAREC, c(kqarec),
& NINFO, c(kinfo), ' Grepos: ', FILIN)
C --Write the initial variables
call expini (ndbout, title, ndim, numnp, numel, nelblk, numnps,
& numess, ierr)
C --Write the coordinates
call expcor (ndbout, a(kxn), a(kyn), a(kzn), ierr)
C --Write the node/element order maps
C ... If the maps are 1..num, then don't write them...
call check_map(ia(kmapel), numel, order)
if (.not. order) then
call expenm (ndbout, ia(kmapel), ierr)
end if
call check_map(ia(kmapnn), numnp, order)
if (.not. order) then
call expnnm (ndbout, ia(kmapnn), ierr)
end if
C --Write the element block
CALL DBOELB (NDBOUT, 1, NELBLK,
& IA(KIDELB), IA(KNELB), IA(KNLNK), IA(KNATR),
& IA(KLINK), c(kbktyp), A(KATRIB))
call putnam(NDBOUT, 1, nelblk, C(KNAMEB))
call putattnam(ndbout, nelblk, ia(kidelb), ia(knatr), c(knamatt))
C --Write the node sets
if (numnps .gt. 0) then
if (lnpsdf .eq. 0) then
do i= 0, numnps-1
ia(kndnps+i) = 0
ia(kixdns+i) = 0
end do
call expcns (ndbout, ia(kidns), ia(knnns), ia(kndnps),
& ia(kixnns), ia(kixdns), ia(kltnns), a(kfacns), ierr)
else
C ... This strangeness is due to bug in gfortran compiler
C which was optimizing out the setting of ia(kidns) and ia(indnps).
C since they are the same as ia(knnns) and ia(kixnns), just use
C those values. Bug is in gfortran-4.8 up to 5.0?
call expcns (ndbout, ia(kidns), ia(knnns), ia(knnns),
& ia(kixnns), ia(kixnns), ia(kltnns), a(kfacns), ierr)
end if
call putnam(NDBOUT, 2, numnps, C(KNAMNP))
end if
C --Write the side sets
if (numess .gt. 0) then
call putss(ndbout, numess, ia(kidss), ia(kness), ia(kndss),
* ia(kixess), ia(kixdss), ia(kltess), ia(kltsss),
* a(kfacss), *40)
call putnam(NDBOUT, 3, numess, C(KNAMSS))
end if
inod2el = 0
do i=1, nvarnp
inod2el = inod2el + ia(kinod2el+i-1)
end do
if (inod2el .gt. 0) then
call mdrsrv('ELEMTIZE', kelmtz, inod2el*numel)
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 40
end if
CALL DBPINI ('NTISV', NDBOUT, TITLE, NDIM, NUMNP, NUMEL, NELBLK,
& NUMNPS, LNPSNL, LNPSDF, NUMESS, LESSEL, LESSDF,
& NVARGL, NVARNP, NVAREL+inod2el, NVARNS, NVARSS, FILOUT)
C ... See if writing the CENTROID field to the database...
if (centrd) then
if (.not. exodus) then
nvarel = ndim
CALL MCRSRV('NAMES', KNAMES, maxnam*NVAREL)
CALL MDRSRV ('ISEVOK', KIEVOK, NELBLK * NVAREL)
CALL MCSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 40
call centnam(c(knames), ia(kievok), nelblk, nvarel, ndim)
ixev = 1
end if
end if
C --Write the database names
if (inod2el .gt. 0) then
call dbonam(ndbout, ndim, c(knamco),
& nvargl, ixgv, nvarnp, ixnv, 0, ixev,
* nvarns, ixnsv, nvarss, ixssv, c(knames))
call mcrsrv('TNAME', KTNAM, maxnam*(nvarel+inod2el))
call eltznam(c(ktnam), c(knames), ixnv, nvarnp,
* ia(kinod2el), ixev, nvarel)
call dbonam(ndbout, 0, c(knamco),
& 0, ixgv, 0, ixnv, nvarel+inod2el, 1,
* 0, ixnsv, 0, ixssv, c(ktnam))
call mcdel('TNAME')
else
call dbonam(ndbout, ndim, c(knamco),
& nvargl, ixgv, nvarnp, ixnv, nvarel, ixev,
* nvarns, ixnsv, nvarss, ixssv, c(knames))
end if
C ... Truth Table.
if (nvarel+inod2el .gt. 0) then
CALL MDRSRV ('ITMP', ktmp, NELBLK * (NVAREL+INOD2EL))
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 40
call dbott(ndbout, 'E', nelblk, nvarel, inod2el,
* la(kievok), ia(ktmp))
call mddel('itmp')
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 40
end if
if (nvarns .gt. 0) then
CALL MDRSRV ('ITMP', ktmp, NUMNPS * NVARNS)
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 40
call dbott(ndbout, 'M', numnps, nvarns, 0, la(knsvok), ia(ktmp))
call mddel('itmp')
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 40
end if
if (nvarss .gt. 0) then
CALL MDRSRV ('ITMP', ktmp, NUMESS * NVARSS)
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 40
call dbott(ndbout, 'S', numess, nvarss, 0, la(kssvok), ia(ktmp))
call mddel('itmp')
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 40
end if
if (centrd .and. .not. exodus) then
istep = 1
time = 0.0
CALL DBOSTE (NDBOUT, ISTEP,
& NVARGL, NVARNP, NUMNP, NVAREL, 0, NELBLK,
& IA(KNELB), LA(KIEVOK), IA(KIDELB),
* NVARNS, NUMNPS, IA(KNNNS), IA(KNSVOK), IA(KIDNS),
* NVARSS, NUMESS, IA(KNESS), IA(KSSVOK), IA(KIDSS),
* TIME, A(KVARGL), A(KVARNP), A(KCENT), A(KVARNS), A(KVARSS),
$ A(1))
call mddel('CENTROID')
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 40
end if
if (.not. exodus) GOTO 50
C --Read the database time steps
MXV = MAX(NVARNP*NUMNP0, NVAREL*NUMEL0,
* NVARNS*LNPSNL0, NVARSS*LESSEL0, INOD2EL*NUMNP0)
CALL MDRSRV ('VARGL', KVARGL, NVARGL)
CALL MDRSRV ('VARNP', KVARNP, NVARNP * NUMNP0)
CALL MDRSRV ('VAREL', KVAREL, (NVAREL+INOD2EL) * NUMEL0)
CALL MDRSRV ('VARNS', KVARNS, NVARNS * LNPSNL0)
CALL MDRSRV ('VARSS', KVARSS, NVARSS * LESSEL0)
IF (RENEL .OR. DELNP .OR. DELEL) THEN
CALL MDRSRV ('VARSCR', KVARSC, MXV)
ELSE
CALL MDRSRV ('VARSCR', KVARSC, 0)
END IF
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 40
WRITE (*, *)
WRITE (*, *)
C ... NOTE: VARNP and VAREL are treated as doubly-dimensioned arrays
C dimensioned as (NUMEL, NVAREL)
iostep = 0
do 110 istep = 1, nsteps
if (ia(kitims+istep-1) .eq. 0) then
iostep = iostep + 1
CALL DBISTE (NDBIN, '*', istep,
& NVARGL,
* NVARNP, NUMNP0,
* NVAREL, NELBLK0, IA(KNELB0), LA(KIEVOK0), IA(KIDELB0),
* NVARNS, NUMNPS0, IA(KNNNS0), IA(KNSVOK0), IA(KIDNS0),
* NVARSS, NUMESS0, IA(KNESS0), IA(KSSVOK0), IA(KIDSS0),
& TIME,
* A(KVARGL), A(KVARNP), A(KVAREL), A(KVARNS), A(KVARSS), *120)
if (istep .eq. idefst) then
C ... The model was deformed at this step, zero out the displacements
C at this step (Technically, should also subtract off this steps
C displacements from every other step, but that isn't supported yet...
C Assumes that displacements are the first 'ndim' nodal variables.
do i=1, ndim*numnp
a(kvarnp+i-1) = 0.0
end do
end if
if (inod2el .gt. 0) then
ioff = 0
inoff = 0
do i=1, nvarnp
if (ia(kinod2el+i-1) .gt. 0) then
call elementize(a(kvarnp+inoff), a(kelmtz+ioff),
* nelblk, ia(knelb), ia(knlnk), ia(klink))
ioff = ioff + numel
end if
inoff = inoff + numnp
end do
end if
IF (RENEL .OR. DELNP .OR. DELEL) THEN
if (nvarnp .gt. 0) then
CALL MAPVAR(NUMNP0, NUMNP, NVARNP, IA(KMAPN),
& A(KVARNP), A(KVARSC))
end if
if (nvarel .gt. 0) then
C ... Pass in the NEW element block parameters (number elements/block),
C number element blocks, and truth table.
CALL MAPEV(NUMEL0, NUMEL, NVAREL, IA(KMAPL),
& A(KVAREL), A(KVARSC))
end if
if (inod2el .gt. 0) then
CALL MAPEV(NUMEL0, NUMEL, inod2el, IA(KMAPL),
& A(kelmtz), A(KVARSC))
end if
END IF
CALL DBOSTE (NDBOUT, IOSTEP,
& NVARGL, NVARNP, NUMNP, NVAREL, INOD2EL, NELBLK,
$ IA(KNELB), LA(KIEVOK), IA(KIDELB),
$ NVARNS, NUMNPS0, IA(KNNNS0), IA(KNSVOK0), IA(KIDNS0),
$ NVARSS, NUMESS0, IA(KNESS0), IA(KSSVOK0), IA(KIDSS0),
$ TIME,
$ A(KVARGL), A(KVARNP), A(KVAREL), A(KVARNS), A(KVARSS),
$ A(KELMTZ))
WRITE (*, 10000) IOSTEP, TIME
10000 FORMAT (' ', I8, ' time steps processed. Time = ',1PE10.3)
end if
110 continue
120 CONTINUE
WRITE (SCRSTR, '(I9)', IOSTAT=K) IOSTEP
CALL SQZSTR (SCRSTR, LSTR)
WRITE (*, 10010) SCRSTR(:LSTR)
10010 FORMAT (/, 4X, A,
& ' time steps have been written to the output database')
GO TO 50
40 CONTINUE
CALL MEMERR
GOTO 50
50 CONTINUE
call mdfree()
call exclos(ndbin, ierr)
call exclos(ndbout, ierr)
60 CONTINUE
call addlog (QAINFO(1)(:lenstr(QAINFO(1))))
CALL WRAPUP (QAINFO(1))
70 FORMAT (/
& 14X,' GGGGG RRRRRR EEEEEEE PPPPPP OOOOO SSSSSS'/
& 14X,'GG GG RR RR EE PP PP OO OO SS '/
& 14X,'GG RR RR EE PP PP OO OO SS '/
& 14X,'GG RRRRRR EEEEE PPPPPP OO OO SSSSS '/
& 14X,'GG GGG RRRRR EE PP OO OO SS'/
& 14X,'GG GG RR RR EE PP OO OO SS'/
& 14X,' GGGGG RR RR EEEEEEE PP OOOOO SSSSSS ')
900 FORMAT(/,'WARNING: ',A,i5,' is a different size in the output',
$ /,9x,'database than in the input database. If there are',
$ /,9x,'variables on this sideset, they will be transferred',
$ /,9x,'incorrectly. Contact gdsjaar@sandia.gov',
$ /,9x,'if you need this capability.')
END
SUBROUTINE INIMAP(LEN, MAP)
INTEGER MAP(*)
DO 10 I=1, LEN
MAP(I) = I
10 CONTINUE
END
subroutine exgqaw(ndb, qarec, ierr)
include 'gp_params.blk'
character*(mxstln) qarec(4, *)
call exgqa(ndb, qarec, ierr)
return
end
subroutine exginw(ndb, info, ierr)
include 'gp_params.blk'
character*(mxlnln) info(*)
call exginf(ndb, info, ierr)
return
end
subroutine dbott(ndbout, type, nblk, nvar, iextra, ievok, itmp)
character*1 type
logical IEVOK(nblk,nvar)
INTEGER ITMP(NVAR+iextra,nblk)
do 20 i=1, nvar
do 10 ielb = 1, nblk
if (ievok(ielb,i)) then
itmp(i,ielb) = 1
else
itmp(i,ielb) = 0
end if
10 continue
20 continue
do i=1, iextra
do ielb = 1, nblk
itmp(i+nvar, ielb) = 1
end do
end do
if (type .eq. 'E') then
call expvtt(ndbout, nblk, nvar+iextra, itmp, ierr)
else if (type .eq. 'M') then
call expnstt(ndbout, nblk, nvar+iextra, itmp, ierr)
else if (type .eq. 'S') then
call expsstt(ndbout, nblk, nvar+iextra, itmp, ierr)
end if
return
end
subroutine centnam(names, isevok, nelblk, nvarel, ndim)
include 'gp_namlen.blk'
character*(maxnam) names(*)
integer isevok(nelblk, nvarel)
names(1)(:maxnam) = 'centroid_x'
if (ndim .ge. 2) names(2)(:maxnam) = 'centroid_y'
if (ndim .eq. 3) names(3)(:maxnam) = 'centroid_z'
do 20 i=1, nelblk
do 10 j=1, nvarel
isevok(i,j) = 1
10 continue
20 continue
return
end
subroutine eltznam(evnames, names, ixnv, nvarnp,
* inod2el, ixev, nvarel)
include 'gp_namlen.blk'
character*(maxnam) names(*), evnames(*)
integer inod2el(*)
do i=1, nvarel
evnames(i) = names(ixev+i-1)
end do
isum = 0
do i=1, nvarnp
if (inod2el(i) .gt. 0) then
isum = isum + 1
evnames(nvarel+isum)(:2) = 'n_'
evnames(nvarel+isum)(3:maxnam) = names(ixnv+i-1)(:maxnam-3)
end if
end do
return
end
SUBROUTINE PRTT(NELBLK, NVAREL, truth)
LOGICAL TRUTH(NELBLK, NVAREL)
DO 10 I=1, NELBLK
WRITE (*,*) (TRUTH(I,IVAR),IVAR=1,NVAREL)
10 CONTINUE
RETURN
END
C...Check whether model contains elements of a single topology.
C This is currently used in the sideset mirroring code
subroutine chktop(nelblk, blktyp, comtop)
include 'exodusII.inc'
integer nelblk
character*(MXSTLN) blktyp(nelblk)
character*(MXSTLN) comtop
comtop = blktyp(1)(:3)
do 10 i=2, nelblk
if (blktyp(i)(:3) .ne. comtop(:3)) then
comtop = 'MULTIPLE_TOPOLOGIES'
return
end if
10 continue
return
end
subroutine getcon(ndb, ndim, nameco, ierr)
include 'gp_namlen.blk'
character*(maxnam) nameco(*)
CALL INISTR (NDIM, ' ', nameco)
call exgcon (ndb, nameco, ierr)
return
end
subroutine getnam(ndb, itype, isiz, names)
include 'gp_namlen.blk'
character*(maxnam) names(*)
call exgnams(ndb, itype, isiz, names, ierr)
return
end
subroutine putnam(ndb, itype, isiz, names)
include 'gp_namlen.blk'
character*(namlen) names(*)
call expnams(ndb, itype, isiz, names, ierr)
return
end
subroutine cpyid(nelblk, idin, idout)
integer idin(nelblk)
integer idout(nelblk)
do i=1, nelblk
idout(i) = idin(i)
end do
return
end
subroutine check_map(map, length, order)
integer map(*)
integer length
logical order
do i = 1, length
if (map(i) .ne. i) then
order = .false.
return
end if
end do
order = .true.
return
end