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.
296 lines
9.2 KiB
296 lines
9.2 KiB
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 WREX2 (MS, MR, NPNODE, NPELEM, MXNFLG, MXSFLG, NPREGN,
|
|
& NPNBC, NPSBC, IUNIT, NNN, KKK, NNXK, NODES, NELEMS, NNFLG,
|
|
& NNPTR, NNLEN, NSFLG, NSPTR, NSLEN, NVPTR, NVLEN, NSIDEN,
|
|
& MAPDXG, XN, YN, NXK, MAT, MAPGXD, MATMAP, WTNODE, WTSIDE,
|
|
& NBCNOD, NNLIST, NBCSID, NSLIST, NVLIST, NUMMAT, LINKM, TITLE,
|
|
& ERR, EIGHT, NINE, VERSN, A, IA, FILENAME)
|
|
C=======================================================================
|
|
C************************************************************************
|
|
|
|
C SUBROUTINE WREX2 = WRITES GENESIS DATABASE MESH OUTPUT
|
|
|
|
C***********************************************************************
|
|
|
|
include 'exodusII.inc'
|
|
|
|
DIMENSION XN (NPNODE), YN (NPNODE), NXK (NNXK, NPELEM)
|
|
DIMENSION MAT (NPELEM)
|
|
DIMENSION NODES (NPNBC), NELEMS (NPSBC), NSIDEN (NPSBC)
|
|
DIMENSION NNFLG (MXNFLG), NNLEN (MXNFLG)
|
|
DIMENSION NNPTR (MXNFLG), WTNODE (NPNBC)
|
|
DIMENSION NSFLG (MXSFLG), NSLEN (MXSFLG)
|
|
DIMENSION NSPTR (MXSFLG), WTSIDE (NPSBC)
|
|
DIMENSION NVLEN (MXSFLG), NVPTR (MXSFLG), LINKM (2, (MS+MR))
|
|
DIMENSION MAPDXG (NPNODE), MAPGXD (NPNODE), MATMAP (3, NPREGN)
|
|
|
|
CHARACTER*(*) FILENAME
|
|
CHARACTER*1 cdum
|
|
CHARACTER*72 TITLE, HOLD*(MXLNLN)
|
|
CHARACTER*(MXSTLN) QAREC(4), CNAME(2)
|
|
CHARACTER*(MXSTLN) ENAME
|
|
CHARACTER*10 VERSN
|
|
|
|
REAL A(*)
|
|
INTEGER IA(*)
|
|
|
|
LOGICAL ERR, EIGHT, NINE
|
|
|
|
integer lcon(9)
|
|
integer lbar(3)
|
|
integer lquad(4)
|
|
|
|
data lcon /1,3,5,7,2,4,6,8,9/
|
|
data lbar /1,3,2/
|
|
data lquad /1,2,3,4/
|
|
|
|
QAREC(1) = ' '
|
|
QAREC(2) = ' '
|
|
QAREC(3) = ' '
|
|
QAREC(4) = ' '
|
|
CALL EXDATE (QAREC(3))
|
|
CALL EXTIME (QAREC(4))
|
|
QAREC(1) = VERSN (1:5)
|
|
QAREC(2) = VERSN (6:10)
|
|
call expqa (iunit, 1, QAREC, ierr)
|
|
|
|
ERR = .TRUE.
|
|
HOLD = TITLE
|
|
CNAME(1) = 'X'
|
|
CNAME(2) = 'Y'
|
|
|
|
C WRITE OUT HEADER INFORMATION
|
|
|
|
IJK = 2
|
|
call expini (iunit, hold, ijk, nnn, kkk, nummat, nbcnod,
|
|
& nbcsid, ierr)
|
|
|
|
C ... WRITE OUT NODE BLOCK
|
|
call expcor (iunit, xn, yn, rdum, ierr)
|
|
call expcon (iunit, cname, ierr)
|
|
|
|
C ... Write out the element map
|
|
call expmap (iunit, mapdxg, ierr)
|
|
|
|
C ... Write out element blocks
|
|
C ... The fastq connectivity storage is not consistent with the
|
|
C exodusII connectivity storage order. Determine the maximum
|
|
C storage required to store the connectivity for an element
|
|
C block and allocate that space. We duplicate some code here,
|
|
C but we don't have any extra arrays to store the information
|
|
MAXLNK = 0
|
|
MAXATT = 0
|
|
DO 90 I = 1, NUMMAT
|
|
NUMEL = MATMAP (3, I) - MATMAP (2, I)+1
|
|
IF (NXK (3, MATMAP (2, I)) .EQ. 0) THEN
|
|
C ...2-NODE BEAM
|
|
INODE = 2
|
|
NATTR = 1
|
|
ELSEIF (NXK (4, MATMAP (2, I)) .EQ. 0) THEN
|
|
C ...3-NODE BEAM
|
|
INODE = 3
|
|
NATTR = 1
|
|
ELSEIF (EIGHT) THEN
|
|
C ...8-NODE QUAD
|
|
INODE = 8
|
|
NATTR = 0
|
|
ELSEIF (NINE) THEN
|
|
C ...9-NODE QUAD
|
|
INODE = 9
|
|
NATTR = 0
|
|
ELSE
|
|
C ...4-NODE QUAD
|
|
INODE = 4
|
|
NATTR = 0
|
|
ENDIF
|
|
maxlnk = max(maxlnk, numel * inode)
|
|
maxatt = max(maxatt, numel * nattr)
|
|
90 CONTINUE
|
|
|
|
C ... Have the maximum size of the link and attribute arrays,
|
|
C Now allocate the space.
|
|
CALL MDRSRV('LINK', KLINK, maxlnk)
|
|
CALL MDRSRV('ATTR', KATRIB, maxatt)
|
|
call mdstat(nerr, mused)
|
|
if (nerr .gt. 0) go to 110
|
|
|
|
DO 100 I = 1, NUMMAT
|
|
IF (NXK (3, MATMAP (2, I)) .EQ. 0) THEN
|
|
INODE = 2
|
|
NATTR = 1
|
|
ATTR = 1.
|
|
ENAME = 'BEAM'
|
|
ELSEIF (NXK (4, MATMAP (2, I)) .EQ. 0) THEN
|
|
INODE = 3
|
|
NATTR = 1
|
|
ATTR = 1.
|
|
ENAME = 'BEAM3'
|
|
ELSEIF (EIGHT) THEN
|
|
INODE = 8
|
|
NATTR = 0
|
|
ENAME = 'QUAD8'
|
|
ELSEIF (NINE) THEN
|
|
INODE = 9
|
|
NATTR = 0
|
|
ENAME = 'QUAD9'
|
|
ELSE
|
|
INODE = 4
|
|
NATTR = 0
|
|
ENAME = 'QUAD'
|
|
ENDIF
|
|
|
|
call expelb(iunit, matmap(1,i), ename,
|
|
& MATMAP (3, I) - MATMAP (2, I)+1, INODE, NATTR, ierr)
|
|
C... 8 or 9 node quads
|
|
IF (INODE .EQ. 8 .or. inode .eq. 9) THEN
|
|
call trnlnk(ia(klink), nxk, nnxk, lcon, nnxk,
|
|
& matmap(2,i), matmap(3,i), .TRUE.)
|
|
call expelc(iunit, matmap(1,i), ia(klink), ierr)
|
|
C... 3 node beam/truss
|
|
ELSEIF (INODE .EQ. 3) THEN
|
|
call trnlnk(ia(klink), nxk, nnxk, lbar, inode,
|
|
& matmap(2,i), matmap(3,i), .TRUE.)
|
|
call expelc(iunit, matmap(1,i), ia(klink), ierr)
|
|
C... 4 node quad or 2 node beam/truss
|
|
ELSE
|
|
call trnlnk(ia(klink), nxk, nnxk, lquad, inode,
|
|
& matmap(2,i), matmap(3,i), .FALSE.)
|
|
call expelc(iunit, matmap(1,i), ia(klink), ierr)
|
|
ENDIF
|
|
if (NATTR .gt. 0) then
|
|
C ... Initialize attributes
|
|
NUMEL = MATMAP (3, I) - MATMAP (2, I)+1
|
|
do 95 iat = 0, nattr*numel-1
|
|
a(katrib+iat) = attr
|
|
95 continue
|
|
call expeat(iunit, matmap(1,i), a(katrib), ierr)
|
|
end if
|
|
c NLOOP = MAX0 (1, NATTR*KKK)
|
|
c WRITE (IUNIT, ERR = 110) (ATTR, J = 1, NLOOP)
|
|
100 CONTINUE
|
|
call mddel('LINK')
|
|
call mddel('ATTR')
|
|
call mdstat(nerr, mused)
|
|
if (nerr .gt. 0) go to 110
|
|
|
|
C WRITE OUT NODAL BOUNDARY FLAGS
|
|
do 200 i = 1, nbcnod
|
|
call expnp (iunit, nnflg(i), nnlen(i), nnlen(i), ierr)
|
|
call expns (iunit, nnflg(i), nodes(nnptr(i)), ierr)
|
|
call expnsd(iunit, nnflg(i), wtnode(nnptr(i)), ierr)
|
|
200 continue
|
|
|
|
C WRITE OUT SIDE BOUNDARY FLAGS
|
|
C ... Fix up side set nodes and elements for 8 and 9 node elements.
|
|
C ... At this point, they are treated as two linear segments,
|
|
C ... They should be ends followed by middle
|
|
|
|
C 1-----3-----2 Now: 1 3 3 2 Correct: 1 2 3
|
|
|
|
if (eight .or. nine) then
|
|
ipn = 1
|
|
ipe = 1
|
|
do 130 ibc = 1, nbcsid
|
|
|
|
ibee = nsptr(ibc)
|
|
iene = nsptr(ibc) + nslen(ibc) - 1
|
|
nsptr(ibc) = ipe
|
|
nslen(ibc) = max(1, nslen(ibc)/2)
|
|
do 115 iel = ibee, iene, 2
|
|
nelems(ipe) = nelems(iel)
|
|
ipe = ipe + 1
|
|
115 continue
|
|
|
|
ibeg = nvptr(ibc)
|
|
iend = nvptr(ibc) + nvlen(ibc) - 1
|
|
nvptr(ibc) = ipn
|
|
nvlen(ibc) = nvlen(ibc) / 4 * 3
|
|
|
|
do 120 inod = ibeg, iend, 4
|
|
nsiden(ipn) = nsiden(inod)
|
|
nsiden(ipn+2) = nsiden(inod+1)
|
|
nsiden(ipn+1) = nsiden(inod+3)
|
|
wtside(ipn) = wtside(inod)
|
|
wtside(ipn+2) = wtside(inod+1)
|
|
wtside(ipn+1) = wtside(inod+3)
|
|
ipn = ipn + 3
|
|
120 continue
|
|
130 continue
|
|
nvlist = ipn - 1
|
|
nslist = ipe - 1
|
|
end if
|
|
|
|
C ... Convert sideset nodes to sideset sides
|
|
if (nbcsid .gt. 0) then
|
|
call mdrsrv('ISIDES', ksides, nslist)
|
|
call EXCN2S(iunit, nslen, nvlen, nsptr, nvptr,
|
|
& nelems, nsiden, ia(ksides), IERR)
|
|
|
|
do 140 i=1, nbcsid
|
|
call expsp (iunit, nsflg(i), nslen(i), nvlen(i), ierr)
|
|
call expss (iunit, nsflg(i), nelems(nsptr(i)),
|
|
& ia(ksides+nsptr(i)-1), ierr)
|
|
call expssd(iunit, nsflg(i), wtside(nvptr(i)), ierr)
|
|
140 continue
|
|
call mddel('ISIDES')
|
|
end if
|
|
C SUCCESSFUL WRITE COMPLETED
|
|
CALL MESSAGE(' ')
|
|
CALL MESSAGE('ExodusII output file successfully written')
|
|
C ... Title is char*72, dbpini and exodusII expect char*80
|
|
HOLD = TITLE
|
|
if (nbcnod .gt. 0) then
|
|
call exinq (iunit, EXNSNL, lnsnl, rdum, cdum, ierr)
|
|
call exinq (iunit, EXNSDF, lnsdf, rdum, cdum, ierr)
|
|
else
|
|
lnsnl = 0
|
|
lnsdf = 0
|
|
end if
|
|
if (nbcsid .gt. 0) then
|
|
call exinq (iunit, EXSSEL, lssel, rdum, cdum, ierr)
|
|
call exinq (iunit, EXSSDF, lssdf, rdum, cdum, ierr)
|
|
call exinq (iunit, EXSSNL, lssnl, rdum, cdum, ierr)
|
|
else
|
|
lssel = 0
|
|
lssdf = 0
|
|
lssnl = 0
|
|
end if
|
|
CALL FQDBPINI ('NTIS', HOLD, ijk, nnn, kkk, nummat, nbcnod,
|
|
* nnlist, nnlist, nbcsid, lssel, lssnl, lssdf, 0, 0, 0,
|
|
* filename)
|
|
ERR = .FALSE.
|
|
RETURN
|
|
|
|
C ERROR DURING WRITE PROBLEMS
|
|
110 CONTINUE
|
|
CALL MESSAGE('ERR DURING WRITE TO OUTPUT FILE')
|
|
CALL MESSAGE('...File may be incomplete...')
|
|
RETURN
|
|
|
|
END
|
|
|
|
subroutine trnlnk(LINK, NXK, NNXK, INDEX, NNODE, IBEG, IEND,USING)
|
|
integer link(nnode, *)
|
|
integer nxk(nnxk, *)
|
|
integer index(*)
|
|
logical using
|
|
|
|
ii = 0
|
|
do 20 i = ibeg, iend
|
|
ii = ii + 1
|
|
do 10 j = 1, nnode
|
|
if (using) then
|
|
link(j,ii) = nxk(index(j), i)
|
|
else
|
|
link(j,ii) = nxk(j, i)
|
|
end if
|
|
10 continue
|
|
20 continue
|
|
return
|
|
end
|
|
|