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.
450 lines
14 KiB
450 lines
14 KiB
C Copyright(C) 1999-2020, 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 GENSHL
|
|
C=======================================================================
|
|
C --*** GENSHL *** (GENSHL) GENESIS 2D to 3D Shell Program
|
|
C --
|
|
C --GENSHL inputs a 2D GENESIS database and outputs a 3D GENESIS database.
|
|
C --
|
|
C --Expected input:
|
|
C -- o The commands on the standard input device.
|
|
C -- o The 2D GENESIS database on unit 9
|
|
C -- (must have 4 nodes per element,
|
|
C -- cannot have more than 2048 element blocks).
|
|
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 3D GENESIS Shell database on unit 10.
|
|
|
|
C --Developed at Sandia National Laboratories.
|
|
C --
|
|
C --Current author and code sponsor: Gregory D. Sjaardema
|
|
C --
|
|
C --Revision History:
|
|
C -- 04/86 GEN3D Created (Amy Gilkey)
|
|
C -- 01/91 GENSHL Created (Greg Sjaardema)
|
|
C --
|
|
C --Source is in FORTRAN 77
|
|
C --
|
|
C --External software used:
|
|
C -- SUPES package (dynamic memory, free-field reader, FORTRAN extensions)
|
|
C -- SUPLIB package (EXODUS file manipulation and other routines)
|
|
C --
|
|
|
|
C --Documentation:
|
|
C -- --NONE--
|
|
|
|
include 'exodusII.inc'
|
|
INCLUDE 'gs_progqa.blk'
|
|
INCLUDE 'gs_dbase.blk'
|
|
INCLUDE 'gs_dbtitl.blk'
|
|
INCLUDE 'gs_dbnums.blk'
|
|
INCLUDE 'gs_dbnum3.blk'
|
|
INCLUDE 'gs_params.blk'
|
|
INCLUDE 'gs_xyzoff.blk'
|
|
INCLUDE 'gs_xyzrot.blk'
|
|
INCLUDE 'gs_xyzmir.blk'
|
|
INCLUDE 'argparse.inc'
|
|
|
|
CHARACTER*2048 FILIN, FILOUT, SCRATCH
|
|
|
|
CHARACTER*(MXSTLN) NAMECO(6)
|
|
CHARACTER*(MXSTLN) NAMELB(2048)
|
|
C --NAMECO - the coordinate names
|
|
C --NAMELB - the element block names
|
|
|
|
CHARACTER CDUM
|
|
|
|
DIMENSION A(1)
|
|
INTEGER IA(1)
|
|
EQUIVALENCE (A(1), IA(1))
|
|
CHARACTER*1 C(1)
|
|
C --A - the dynamic numeric memory base array
|
|
|
|
INTEGER IDNSET(0:10,2)
|
|
INTEGER IDESET(0:10,2)
|
|
|
|
INCLUDE 'gs_qainfo.blk'
|
|
|
|
CALL STRTUP (QAINFO)
|
|
|
|
CALL BANNER (0, QAINFO,
|
|
& 'A GENESIS DATABASE 2D TO 3D SHELL CONVERSION PROGRAM',
|
|
& ' ', ' ')
|
|
call cpyrgt (0, '1991')
|
|
|
|
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
|
|
NARG = argument_count()
|
|
if (narg .lt. 2) then
|
|
CALL PRTERR ('FATAL', 'Filenames not specified.')
|
|
CALL PRTERR ('CMDSPEC',
|
|
* 'Syntax is: "genshell 2dfilename 3dfilename"')
|
|
CALL PRTERR ('CMDSPEC',
|
|
* 'Documentation: https://sandialabs.github.io' //
|
|
$ '/seacas-docs/sphinx/html/index.html#genshell')
|
|
GOTO 60
|
|
else if (narg .gt. 2) then
|
|
CALL PRTERR ('FATAL', 'Too many arguments specified.')
|
|
CALL PRTERR ('CMDSPEC',
|
|
* 'Syntax is: "genshell 2dfilename 3dfilename"')
|
|
CALL PRTERR ('CMDSPEC',
|
|
* 'Documentation: https://sandialabs.github.io' //
|
|
$ '/seacas-docs/sphinx/html/index.html#genshell')
|
|
GOTO 60
|
|
end if
|
|
|
|
C --Open the input database and read the initial variables
|
|
|
|
NDBIN = 9
|
|
NDBOUT = 10
|
|
|
|
CMPSIZ = 0
|
|
IOWS = 0
|
|
|
|
FILIN = ' '
|
|
CALL get_argument(1,FILIN, LNAM)
|
|
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 (nelblk .gt. 2048) then
|
|
CALL PRTERR ('PROGRAM', 'Too many element blocks. 2048 MAX')
|
|
GOTO 60
|
|
end if
|
|
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, EXSSNL, lessnl, rdum, cdum, ierr)
|
|
call exinq(ndbin, EXSSEL, lessel, rdum, cdum, ierr)
|
|
call exinq(ndbin, EXSSDF, lessdf, rdum, cdum, ierr)
|
|
else
|
|
lessnl = 0
|
|
lessel = 0
|
|
lessdf = 0
|
|
end if
|
|
|
|
CALL DBPINI ('NTIS', NDBIN, TITLE, NDIM, NUMNP, NUMEL, NELBLK,
|
|
& NUMNPS, LNPSNL, LNPSDF, NUMESS, LESSEL, LESSNL,
|
|
& LESSDF, IDUM, IDUM, IDUM)
|
|
|
|
IF (NDIM .NE. 2) THEN
|
|
CALL PRTERR ('FATAL', 'Number of dimensions must be 2')
|
|
GOTO 60
|
|
END IF
|
|
|
|
C --Reserve memory for the 2D information
|
|
|
|
CALL MDRSRV ('XN', KXN, NUMNP)
|
|
CALL MDRSRV ('YN', KYN, NUMNP)
|
|
KZN = 1
|
|
|
|
CALL MDRSRV ('MAPEL', KMAPEL, NUMEL)
|
|
|
|
CALL MDRSRV ('IDELB', KIDELB, NELBLK)
|
|
CALL MDRSRV ('NUMELB', KNELB, NELBLK)
|
|
CALL MDRSRV ('NUMLNK', KNLNK, NELBLK)
|
|
CALL MDRSRV ('NUMATR', KNATR, NELBLK)
|
|
CALL MDRSRV ('LINK', KLINK, 0)
|
|
CALL MDRSRV ('ATRIB', KATRIB, 0)
|
|
|
|
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, LNPSNL)
|
|
|
|
CALL MDRSRV ('IDESS', KIDSS, NUMESS)
|
|
CALL MDRSRV ('NEESS', KNESS, NUMESS)
|
|
CALL MDRSRV ('NNESS', KNNSS, NUMESS)
|
|
CALL MDRSRV ('NDESS', KNDSS, NUMESS)
|
|
CALL MDRSRV ('IXEESS', KIXESS, NUMESS)
|
|
CALL MDRSRV ('IXNESS', KIXNSS, NUMESS)
|
|
CALL MDRSRV ('IXDESS', KIXDSS, NUMESS)
|
|
CALL MDRSRV ('LTNNSS', KLTNNN, LESSEL)
|
|
CALL MDRSRV ('LTEESS', KLTESS, LESSEL)
|
|
CALL MDRSRV ('LTNESS', KLTNSS, LESSNL)
|
|
CALL MDRSRV ('LTSESS', KLTSSS, LESSEL)
|
|
CALL MDRSRV ('FACESS', KFACSS, LESSNL)
|
|
|
|
CALL MDSTAT (NERR, MEM)
|
|
IF (NERR .GT. 0) GOTO 40
|
|
|
|
C --Read 2D information from the database and close file
|
|
|
|
call exgcor (ndbin, a(kxn), a(kyn), a(kzn), ierr)
|
|
call exgmap (ndbin, ia(kmapel), ierr)
|
|
|
|
CALL INISTR (NDIM, ' ', NAMECO)
|
|
call exgcon (ndbin, nameco, ierr)
|
|
|
|
CALL INISTR (2048, ' ', NAMELB)
|
|
CALL DBIELB (NDBIN, '*', 1, NELBLK,
|
|
* IA(KIDELB), IA(KNELB), IA(KNLNK), IA(KNATR),
|
|
* A, IA, KLINK, KATRIB, NAMELB, *60)
|
|
CALL MDSTAT (NERR, MEM)
|
|
IF (NERR .GT. 0) GOTO 40
|
|
|
|
C ... At the current time, only handle all 4-node or 8-node hexes per model.
|
|
NLNK = IA(KNLNK)
|
|
DO 5 IEL = 2, NELBLK
|
|
if (NLNK .NE. IA(KNLNK+IEL-1)) THEN
|
|
CALL PRTERR ('FATAL',
|
|
* 'Mesh must be ALL 4-node or ALL 8-node quads')
|
|
STOP
|
|
END IF
|
|
5 CONTINUE
|
|
|
|
if (numnps .gt. 0) then
|
|
call exgcns(ndbin, a(kidns), a(knnns), a(kndnps), a(kixnns),
|
|
* a(kixdns), a(kltnns), a(kfacns), ierr)
|
|
end if
|
|
|
|
if (numess .gt. 0) then
|
|
call exgcss(ndbin, a(kidss), a(kness), a(kndss), a(kixess),
|
|
* a(kixdss), A(KLTeSS), a(kltsss), a(kfacss), ierr)
|
|
end if
|
|
|
|
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+1) * 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
|
|
|
|
IF ((NQAREC .GT. 0) .OR. (NINFO .GT. 0)) THEN
|
|
CALL DBPQA ('*', NQAREC, c(kqarec), NINFO, c(kinfo))
|
|
END IF
|
|
|
|
C -- This assumes only max of 7 attributes per element block
|
|
CALL MDRSRV ('ATRIBNW', KATRIBN, 0)
|
|
CALL MDRSRV ('ELATTR', KELATT, NELBLK*7)
|
|
CALL MDSTAT (NERR, MEM)
|
|
IF (NERR .GT. 0) GOTO 40
|
|
|
|
C --Read in runtime parameters
|
|
|
|
CALL COMAND (IA(KIDNS), IA(KIDSS), IDNSET, IDESET,
|
|
& IA(KIDELB), IA(KNELB), IA(KNLNK), NAMELB, A(KELATT),
|
|
& A(KXN), A(KYN), A, *60)
|
|
|
|
C --Get the new numbers for the elements and nodes
|
|
|
|
LNPSNO = LNPSNL
|
|
|
|
C --Get the node sets
|
|
|
|
CONTINUE
|
|
|
|
C --Get the side sets, and the front and back side sets
|
|
|
|
NSSET = IDESET(0,1)+IDESET(0,2)
|
|
IF (NSSET .GT. 0) THEN
|
|
CALL MDRSRV ('ISSFRO', KISFRO, NUMEL)
|
|
CALL MDRSRV ('ISSBCK', KISBCK, NUMEL)
|
|
CALL MDRSRV ('NSSFRO', KNSFRO, NLNK*NUMEL)
|
|
CALL MDRSRV ('NSSBCK', KNSBCK, NLNK*NUMEL)
|
|
ELSE
|
|
KISFRO = 1
|
|
KISBCK = 1
|
|
KNSFRO = 1
|
|
KNSBCK = 1
|
|
END IF
|
|
|
|
LESSEO = INTADD (NUMESS, IA(KNESS))
|
|
LESSNO = INTADD (NUMESS, IA(KNDSS))
|
|
|
|
CALL NEWESS
|
|
& (IDESET(0,1), IDESET(0,2), NSSUR, NLNK,
|
|
& IA(KLINK), IA(KISFRO), IA(KISBCK), IA(KNSFRO), IA(KNSBCK))
|
|
|
|
IF (NSSET .GT. 0) THEN
|
|
CALL MDLONG ('NSSFRO', KNSFRO, NSSUR)
|
|
CALL MDLONG ('NSSBCK', KNSBCK, NSSUR)
|
|
END IF
|
|
CALL MDSTAT (NERR, MEM)
|
|
IF (NERR .GT. 0) GOTO 40
|
|
|
|
C --Open the output database
|
|
FILOUT = ' '
|
|
CALL get_argument(2,FILOUT, LFIL)
|
|
CMPSIZ = 0
|
|
IOWS = iowdsz()
|
|
ndbout = excre(filout(:lfil), EXCLOB, CMPSIZ, IOWS, IERR)
|
|
if (ierr .lt. 0) then
|
|
call exopts (EXVRBS, ierr)
|
|
call exerr('grepos', 'Error from excre', ierr)
|
|
go to 50
|
|
endif
|
|
|
|
C --Write the initial variables
|
|
|
|
CALL NEWINI (IDNSET(0,1)+IDNSET(0,2), IDESET(0,1)+IDESET(0,2),
|
|
& NSSUR, IA(KNATR))
|
|
call expini (ndbout, title, ndim3, numnp3, numel3, nelbl3,
|
|
& nnps3, ness3, ierr)
|
|
|
|
CALL DBPINI ('NTIS', NDBOUT, TITLE, NDIM3, NUMNP3, NUMEL3, NELBL3,
|
|
& NNPS3, LNPSN3, LNPSN3, NESS3, LESSE3, LESSN3, LESSN3,
|
|
& IDUM, IDUM, IDUM)
|
|
|
|
C --Write the coordinates
|
|
|
|
CALL MDRSRV ('XN3', KXN3, NUMNP3)
|
|
CALL MDRSRV ('YN3', KYN3, NUMNP3)
|
|
CALL MDRSRV ('ZN3', KZN3, NUMNP3)
|
|
|
|
C -- Since we only read quads, NUMATR should be 0. For a shell, we
|
|
C have 1 attribute (thickness)
|
|
|
|
CALL MDLONG ('ATRIB', KATRIB, NUMEL3)
|
|
|
|
CALL MDSTAT (NERR, MEM)
|
|
IF (NERR .GT. 0) GOTO 40
|
|
|
|
CALL NEWXYZ (A(KXN), A(KYN), A(KXN3), A(KYN3), A(KZN3),
|
|
$ A(KATRIB), A )
|
|
call expcor (ndbout, a(kxn3), a(kyn3), a(kzn3), ierr)
|
|
|
|
NAMECO(1) = 'X'
|
|
NAMECO(2) = 'Y'
|
|
NAMECO(3) = 'Z'
|
|
call expcon(ndbout, nameco, ierr)
|
|
|
|
CALL MDDEL ('XN')
|
|
CALL MDDEL ('YN')
|
|
CALL MDDEL ('XN3')
|
|
CALL MDDEL ('YN3')
|
|
CALL MDDEL ('ZN3')
|
|
CALL MDSTAT (NERR, MEM)
|
|
IF (NERR .GT. 0) GOTO 40
|
|
|
|
C --Write the element order map - NOTE: New map is same as old map
|
|
call expmap (ndbout, ia(kmapel), ierr)
|
|
CALL MDDEL ('MAPEL')
|
|
|
|
C --Fixup connectivity if mirrored
|
|
IF (XMIRR * YMIRR * ZMIRR .LT. 0.0) THEN
|
|
CALL DBMIRR (1, NELBLK, IA(KIDELB), IA(KNELB),
|
|
$ IA(KNLNK), IA(KLINK))
|
|
END IF
|
|
C --Write the element block
|
|
|
|
ILOFF = 0
|
|
IAOFF = 0
|
|
DO 30 I = 1, NELBLK
|
|
C ... Calculate these here since values may change if BEAM...
|
|
II = I - 1
|
|
ILINC = IA(KNELB+II) * IA(KNLNK+II)
|
|
IAINC = IA(KNELB+II) * IA(KNATR+II)
|
|
IF (NAMELB(I)(:4) .EQ. 'QUAD' .OR. NAMELB(I) .EQ. ' ') THEN
|
|
NAMELB(I) = 'SHELL'
|
|
ELSE IF (NAMELB(I)(:4) .EQ. 'BEAM') THEN
|
|
IA(KNATR+I-1) = 7
|
|
ELSE
|
|
CALL PRTERR ('CMDWARN',
|
|
$ 'Invalid Element Block Type')
|
|
END IF
|
|
CALL DBOELB (A, NDBOUT, IA(KIDELB+II), IA(KNELB+II),
|
|
$ IA(KNLNK+II), IA(KNATR+II), IA(KLINK+ILOFF),
|
|
* NAMELB(I), A(KATRIB), A(KELATT+(II*7)))
|
|
ILOFF = ILOFF + ILINC
|
|
IAOFF = IAOFF + IAINC
|
|
|
|
30 CONTINUE
|
|
|
|
CALL MDDEL ('LINK')
|
|
CALL MDDEL ('ATRIB')
|
|
CALL MDSTAT (NERR, MEM)
|
|
IF (NERR .GT. 0) GOTO 40
|
|
|
|
C --Write the node sets
|
|
|
|
CALL WRNPS (A, IA, IDNSET(0,1), IDNSET(0,2), IA(KIDNS),
|
|
& IA(KNNNS), IA(KIXNNS), IA(KLTNNS), A(KFACNS), *40)
|
|
|
|
C --Fixup sides sets if mirrored
|
|
c$$$ IF (XMIRR * YMIRR * ZMIRR .LT. 0.0) THEN
|
|
c$$$ CALL MIRSS (IDESET(0,1), IDESET(0,2), NLNK,
|
|
c$$$ & NSSUR, IA(KNSFRO), IA(KNSBCK), IA(KLTSSS))
|
|
c$$$ END IF
|
|
C --Write the side sets
|
|
|
|
CALL WRESS (A, IA, IDESET(0,1), IDESET(0,2),
|
|
& IA(KISFRO), IA(KISBCK), NSSUR, IA(KNSFRO), IA(KNSBCK),
|
|
& IA(KIDSS), IA(KNESS), IA(KNDSS), IA(KIXESS), IA(KIXDSS),
|
|
& IA(KLTESS), IA(KLTSSS), A(KFACSS), *40)
|
|
|
|
IF (NSSET .GT. 0) THEN
|
|
CALL MDDEL ('ISSFRO')
|
|
CALL MDDEL ('ISSBCK')
|
|
CALL MDDEL ('NSSFRO')
|
|
CALL MDDEL ('NSSBCK')
|
|
END IF
|
|
CALL MDSTAT (NERR, MEM)
|
|
IF (NERR .GT. 0) GOTO 40
|
|
|
|
C --Write the QA records
|
|
CALL DBOQA (NDBOUT, QAINFO, NQAREC, c(kqarec),
|
|
& NINFO, c(kinfo), ' GenShell: ', FILIN)
|
|
|
|
GOTO 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))
|
|
|
|
END
|
|
|
|
subroutine exgqaw(ndb, qarec, ierr)
|
|
include 'exodusII.inc'
|
|
character*(mxstln) qarec(4, *)
|
|
call exgqa(ndb, qarec, ierr)
|
|
return
|
|
end
|
|
|
|
subroutine exginw(ndb, info, ierr)
|
|
include 'exodusII.inc'
|
|
character*(mxlnln) info(*)
|
|
call exginf(ndb, info, ierr)
|
|
return
|
|
end
|
|
|