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.
238 lines
7.9 KiB
238 lines
7.9 KiB
2 years ago
|
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=======================================================================
|
||
|
|
SUBROUTINE WRGEN (A,IA, FILNAM, TITLE, NDIM, NUMNP, NUMEL, NELBLK,
|
||
|
|
& NUMNPS, LNPSNL, NUMESS, LESSEL, LESSDL,
|
||
|
|
& KXN, KYN, KZN, KMAPEL,
|
||
|
|
& KIDELB, KNELB, KNLNK, KNATR, KLINK, KATRIB,
|
||
|
|
& KIDNS, KNNNS, KIXNNS, KLTNNS, KFACNS,
|
||
|
|
& KIDSS, KNESS, KNDSS, KIXESS, KIXDSS, KLTESS, KFACSS,
|
||
|
|
& kltsss, NQAREC, QAREC, NINFO, INFREC, NAMELB, L64BIT, NC4,
|
||
|
|
$ NAMBK, NAMNS, NAMSS, *)
|
||
|
|
C=======================================================================
|
||
|
|
|
||
|
|
C --*** WRGEN *** (GJOIN) Writes the GENESIS database
|
||
|
|
C -- Written by Amy Gilkey - revised 02/22/88
|
||
|
|
C --
|
||
|
|
C --WRGEN writes the GENESIS database.
|
||
|
|
C --
|
||
|
|
C --Parameters:
|
||
|
|
C -- A - IN/OUT - the dynamic memory base array
|
||
|
|
C -- FILNAM - IN - the database filename
|
||
|
|
C -- TITLE - IN - the database title
|
||
|
|
C -- NDIM - IN - the number of coordinates per node
|
||
|
|
C -- NUMNP - IN - the number of nodes
|
||
|
|
C -- NUMEL - IN - the number of elements
|
||
|
|
C -- NELBLK - IN - the number of element blocks
|
||
|
|
C -- NUMNPS - IN - the number of nodal point sets
|
||
|
|
C -- LNPSNL - IN - the length of the nodal point sets node list
|
||
|
|
C -- NUMESS - IN - the number of side sets
|
||
|
|
C -- LESSEL - IN - the length of the element side sets element list
|
||
|
|
C -- LESSNL - IN - the length of the element side sets node list
|
||
|
|
C -- KXN, KYN, KZN - IN - index of XN, YN, ZN; nodal coordinates
|
||
|
|
C -- KMAPEL - IN - index of MAPEL; the element order map
|
||
|
|
C -- KIDELB - IN - index of IDELB; the element block IDs for each block
|
||
|
|
C -- KNELB - IN - index of NUMELB; the number of elements in each block
|
||
|
|
C -- KNLNK - IN - index of NUMLNK; the number of nodes per element
|
||
|
|
C -- in each block
|
||
|
|
C -- KNATR - IN - index of NUMATR; the number of attributes in each block
|
||
|
|
C -- KLINK - IN - index of LINK; the connectivity for each block
|
||
|
|
C -- KATRIB - IN - index of ATRIB; the attributes for each block
|
||
|
|
C ... Nodesets
|
||
|
|
C -- KIDNS - IN - index of IDNPS; the nodal point set ID for each set
|
||
|
|
C -- KNNNS - IN - index of NNNPS; the number of nodes for each set
|
||
|
|
C -- KIXNNS - IN - index of IXNNPS; the index of the first node for each set
|
||
|
|
C -- KLTNNS - IN - index of LTNNPS; the nodes for all sets
|
||
|
|
C -- KFACNS - IN - index of FACNPS; the distribution factors for all sets
|
||
|
|
C .... Sidesets
|
||
|
|
C -- KIDSS - IN - index of IDESS; the element side set ID for each set
|
||
|
|
C -- KNESS - IN - index of NEESS; the number of elements for each set
|
||
|
|
C -- KIXESS - IN - index of IXEESS; the index of the first element
|
||
|
|
C -- for each set
|
||
|
|
C -- KLTESS - IN - index of LTEESS; the elements for all sets
|
||
|
|
C -- KFACSS - IN - index of FACESS; the distribution factors for all sets
|
||
|
|
C -- NAMELB - IN - the names of the element blocks
|
||
|
|
C -- L64BIT - IN - true if use 64-bit integer output database
|
||
|
|
|
||
|
|
include 'exodusII.inc'
|
||
|
|
include 'gj_params.blk'
|
||
|
|
include 'gj_namlen.blk'
|
||
|
|
|
||
|
|
DIMENSION A(*), IA(*)
|
||
|
|
CHARACTER*(*) FILNAM
|
||
|
|
character*(MXLNLN) title
|
||
|
|
character*(MXSTLN) qarec(4,MAXQA)
|
||
|
|
character*(MXLNLN) infrec(MAXINF)
|
||
|
|
character*(MXSTLN) nameco(6), namelb(*)
|
||
|
|
character*(namlen) nambk(*), namns(*), namss(*)
|
||
|
|
LOGICAL l64bit, NC4
|
||
|
|
|
||
|
|
C --QAREC - the QA records
|
||
|
|
C --INFREC - the information records
|
||
|
|
integer cpuws,wsout
|
||
|
|
|
||
|
|
DATA NAMECO /'X', 'Y', 'Z', 'RX', 'RY', 'RZ'/
|
||
|
|
|
||
|
|
C Make netCDF and exodus errors not show up
|
||
|
|
|
||
|
|
call exopts (0,ierr)
|
||
|
|
wsout = iowdsz()
|
||
|
|
write(*,*)'Output word size: ',wsout
|
||
|
|
|
||
|
|
C --Open the database
|
||
|
|
C Create the netcdf file
|
||
|
|
|
||
|
|
CALL SQZSTR(FILNAM, LNAM)
|
||
|
|
LNAM = LENSTR (FILNAM)
|
||
|
|
|
||
|
|
cpuws = 0
|
||
|
|
MODE = EX_CLOBBER
|
||
|
|
if (l64bit) then
|
||
|
|
MODE = MODE + EX_ALL_INT64_DB + EX_ALL_INT64_API
|
||
|
|
end if
|
||
|
|
if (nc4) then
|
||
|
|
MODE = MODE + EX_NETCDF4
|
||
|
|
end if
|
||
|
|
idexo = excre (filnam(:lnam), MODE, cpuws, wsout, ierr)
|
||
|
|
if (ierr .lt. 0) then
|
||
|
|
call exerr('gjoin2', 'Error from excre', exlmsg)
|
||
|
|
go to 150
|
||
|
|
endif
|
||
|
|
|
||
|
|
C -- Set output name length
|
||
|
|
call exmxnm(idexo, namlen, ierr)
|
||
|
|
|
||
|
|
C --Write the QA records
|
||
|
|
|
||
|
|
if (nqarec .gt. 0) then
|
||
|
|
call expqa (idexo, nqarec, qarec, ierr)
|
||
|
|
if (ierr .lt. 0) then
|
||
|
|
call exerr ('gjoin2', 'Error from expqa', exlmsg)
|
||
|
|
goto 150
|
||
|
|
endif
|
||
|
|
endif
|
||
|
|
|
||
|
|
C --Write the info records
|
||
|
|
|
||
|
|
if (ninfo .gt. 0) then
|
||
|
|
call expinf (idexo, ninfo, infrec, ierr)
|
||
|
|
if (ierr .lt. 0) then
|
||
|
|
call exerr ('gjoin2', 'Error from expinf', exlmsg)
|
||
|
|
goto 150
|
||
|
|
endif
|
||
|
|
endif
|
||
|
|
|
||
|
|
lnpsdl = 0
|
||
|
|
if (numnps .gt. 0) then
|
||
|
|
call mdrsrv('NSDF', kansdf, numnps)
|
||
|
|
do 90 i=1, numnps
|
||
|
|
ia(kansdf+i-1) = ia(knnns+i-1)
|
||
|
|
lnpsdl = lnpsdl + ia(kansdf+i-1)
|
||
|
|
90 continue
|
||
|
|
end if
|
||
|
|
|
||
|
|
IDUM = 0
|
||
|
|
CALL DBPINI ('NTIS', idexo, TITLE, NDIM, NUMNP, NUMEL, NELBLK,
|
||
|
|
& NUMNPS, LNPSNL, lnpsdl, NUMESS, LESSEL, LESSDL,
|
||
|
|
& IDUM, IDUM, IDUM, FILNAM(:LNAM))
|
||
|
|
|
||
|
|
C --Write the initial variables
|
||
|
|
|
||
|
|
call expini (idexo, title, ndim, numnp, numel, nelblk, numnps,
|
||
|
|
& numess, ierr)
|
||
|
|
if (ierr .lt. 0) then
|
||
|
|
call exerr ('gjoin2', ' Error from expini', exlmsg)
|
||
|
|
goto 150
|
||
|
|
endif
|
||
|
|
|
||
|
|
C --Write the coordinates
|
||
|
|
|
||
|
|
call expcor (idexo, a(kxn), a(kyn), a(kzn), ierr)
|
||
|
|
if (ierr .lt. 0) then
|
||
|
|
call exerr ('gjoin2', 'Error from expcor', exlmsg)
|
||
|
|
goto 150
|
||
|
|
endif
|
||
|
|
|
||
|
|
call expcon (idexo, nameco, ierr)
|
||
|
|
if (ierr .lt. 0) then
|
||
|
|
call exerr ('gjoin2', 'Error from expcon', exlmsg)
|
||
|
|
goto 150
|
||
|
|
endif
|
||
|
|
|
||
|
|
C --Write out the nodal point sets
|
||
|
|
|
||
|
|
if (numnps .gt. 0) then
|
||
|
|
call expcns (idexo, ia(kidns), ia(knnns), ia(kansdf),
|
||
|
|
& ia(kixnns), ia(kixnns), ia(kltnns),
|
||
|
|
& a(kfacns), ierr)
|
||
|
|
if (ierr .lt. 0) then
|
||
|
|
call exerr ('gjoin2', 'Error from expcns', exlmsg)
|
||
|
|
goto 150
|
||
|
|
endif
|
||
|
|
call mddel('NSDF')
|
||
|
|
call expnams(idexo, 2, numnps, namns, ierr)
|
||
|
|
endif
|
||
|
|
|
||
|
|
C --Write element side sets
|
||
|
|
if (numess .gt. 0) then
|
||
|
|
call expcss (idexo, ia(kidss), ia(kness), ia(kndss),
|
||
|
|
& ia(kixess), ia(kixdss), ia(kltess),
|
||
|
|
& ia(kltsss), a(kfacss), ierr)
|
||
|
|
if (ierr .lt. 0) then
|
||
|
|
call exerr ('gjoin2', 'Error from expcss', exlmsg)
|
||
|
|
goto 150
|
||
|
|
endif
|
||
|
|
call expnams(idexo, 3, numess, namss, ierr)
|
||
|
|
endif
|
||
|
|
|
||
|
|
C --Write the element blocks
|
||
|
|
|
||
|
|
C Write concatenated element block parameters
|
||
|
|
call expclb (idexo, ia(kidelb), namelb,
|
||
|
|
& ia(knelb), ia(knlnk), ia(knatr), .FALSE., ierr)
|
||
|
|
if (ierr .lt. 0) then
|
||
|
|
call exerr('gjoin2', 'Error from expclb', exlmsg)
|
||
|
|
goto 150
|
||
|
|
endif
|
||
|
|
|
||
|
|
ioff = katrib
|
||
|
|
iptr = klink
|
||
|
|
do 100 ielb = 1, nelblk
|
||
|
|
|
||
|
|
C Write block attributes
|
||
|
|
|
||
|
|
if (ia(knatr+ielb-1) .gt. 0) then
|
||
|
|
call expeat (idexo, ia(kidelb+ielb-1), a(ioff), ierr)
|
||
|
|
if (ierr .lt. 0) then
|
||
|
|
call exerr ('gjoin2', 'Error from expeat', exlmsg)
|
||
|
|
goto 150
|
||
|
|
endif
|
||
|
|
endif
|
||
|
|
|
||
|
|
C Write the element block connectivity,
|
||
|
|
C skipping null element blocks
|
||
|
|
|
||
|
|
if (ia(knelb+ielb-1) .eq. 0) then
|
||
|
|
write(*,*)'Null element block: ',ielb
|
||
|
|
else
|
||
|
|
call expelc (idexo, ia(kidelb+ielb-1), ia(iptr), ierr)
|
||
|
|
if (ierr .lt. 0) then
|
||
|
|
call exerr ('gjoin2', 'Error from expelc', exlmsg)
|
||
|
|
goto 150
|
||
|
|
endif
|
||
|
|
endif
|
||
|
|
|
||
|
|
ioff = ioff + ( ia(knatr+ielb-1) * ia(knelb+ielb-1) )
|
||
|
|
iptr = iptr + ( ia(knlnk+ielb-1) * ia(knelb+ielb-1) )
|
||
|
|
100 continue
|
||
|
|
call expnams(idexo, 1, nelblk, nambk, ierr)
|
||
|
|
|
||
|
|
150 call exclos (idexo, ierr)
|
||
|
|
|
||
|
|
RETURN
|
||
|
|
END
|