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.
3 Commits
1 Branch
0 Tags
19 MiB
 
 
 
 
 
 
Tag: Branch: Tree: ec572c6da6
Branches Tags
${ item.name }
Create tag ${ searchTerm }
Create branch ${ searchTerm }
from 'ec572c6da6'
${ noResults }
EXODUS/packages/seacas/applications/gjoin/gjoin.f

743 lines
22 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 -*- Mode: fortran -*-
C=======================================================================
PROGRAM GJOIN2
C=======================================================================
C *** GJOIN2 ***
C --*** GJOIN2 *** (GJOIN) GENESIS database combination program
C -- Written by Amy Gilkey - revised 03/04/88
C --
C --GJOIN2 combines two or more GENESIS II databases into a single database.
C --
C --Expected input:
C -- o Responses from the user on the standard input device.
C -- o The input databases (name requested)
C --
C --Output:
C -- o Prompts on the standard output device.
C -- o The output database (name requested)
C --Developed at Sandia National Laboratories.
C --
C --Current author and code sponsor: 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 --
C --Documentation:
C -- "User's Manual for GJOIN"
include 'exodusII.inc'
include 'gj_params.blk'
include 'gj_progqa.blk'
include 'gj_titles.blk'
include 'gj_dbvars.blk'
include 'gj_filnum.blk'
include 'gj_xyzrot.blk'
include 'argparse.inc'
DIMENSION A(1), IA(1)
C --A - the dynamic numeric memory base array
EQUIVALENCE (A(1),IA(1))
character*1 c(1)
LOGICAL USESDF, NONQUD, L64BIT, NC4
LOGICAL RENNP, RENEL, REN, DELNP, DELEL, BATCH, CLOSE, MATMAT
LOGICAL FIRST, DONE, MDEBUG
character*(2048) filnam, string, syntax, scratch
C... String containing name of common element topology in model
C or 'MULTIPLE_TOPOLOGIES' if not common topology.
character*(MXSTLN) comtop
character*(MXSTLN) qarec(4,MAXQA)
character*(MXLNLN) infrec(MAXINF)
C --QAREC - the QA records
C --INFREC - the information records
include 'gj_qainfo.blk'
L64BIT = .false.
Nc4 = .false.
CALL STRTUP (QAINFO)
CALL BANNER (0, QAINFO,
& 'A GENESIS DATABASE COMBINATION PROGRAM',
& ' ', ' ')
call cpyrgt (0, '1988')
C --Open LOG file if running interactively
IF (.NOT. BATCH()) THEN
KLOG = 99
OPEN (UNIT=KLOG, FILE='gjoin.log', FORM='formatted',
& STATUS='unknown', IOSTAT=IERR)
IF (IERR .NE. 0) THEN
CALL PRTERR ('ERROR', 'Could not open log file')
GOTO 150
END IF
ELSE
KLOG = 0
END IF
C --Initialize dynamic memory
NQAREC = 0
NINFO = 0
CALL MDINIT (A)
CALL MCINIT (C)
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 140
MDEBUG = .false.
C if (MDEBUG) then
C call mlist()
C end if
FIRST = .TRUE.
USESDF = .FALSE.
80 CONTINUE
C .. Get filename from command line. If not specified, emit error message
SYNTAX = 'Syntax is: "gjoin [-64] [-netcdf4]"'
NARG = argument_count()
C ... Parse options...
name_len = 0
if (narg .ge. 1) then
iarg = 1
do
CALL get_argument(iarg,STRING, LNAM)
iarg = iarg + 1
if (string(:lnam) .eq. '-64') then
l64bit = .true.
else if (string(:lnam) .eq. '-netcdf4') then
nc4 = .true.
else
SCRATCH =
* 'Unrecognized command option "'//STRING(:LNAM)//'"'
CALL PRTERR ('FATAL', SCRATCH(:LENSTR(SCRATCH)))
CALL PRTERR ('CMDSPEC', SYNTAX(:LENSTR(SYNTAX)))
CALL PRTERR ('CMDSPEC',
* 'Documentation: https://sandialabs.github.io' //
$ '/seacas-docs/sphinx/html/index.html#gjoin')
go to 150
end if
if (iarg .ge. narg) exit
end do
end if
CALL INIGEN (A, FIRST,
& KXN, KYN, KZN, KMAPEL,
& KIDELB, KNELB, KNLNK, KNATR, KLINK, KATRIB,
& KIDNS, KNNNS, KIXNNS, KLTNNS, KFACNS,
& KIDSS, KNESS, KNDSS, KIXESS, KIXDSS, KLTESS, kltsss,
& kltsnc, kfacss, KNMLB, KNMBK, KNMNS, KNMSS)
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 140
C --Open and read the database
WRITE (*, *)
IF (FIRST) THEN
90 CONTINUE
CALL GETINP (0, 0, 'First input file> ', FILNAM, IOSTAT)
IF (IOSTAT .LT. 0) GOTO 150
IF (FILNAM(1:1) .EQ. '$' .OR. LENSTR(FILNAM) .LE. 1) GOTO 90
CALL OUTLOG (KLOG, 1, 0, FILNAM, IDUM, RDUM)
END IF
CALL RDGEN (A, IA, C, FIRST, FILNAM,
& TITLE1, NDIM, NUMNP1, NUMEL1, NELBL1,
& NNPS1, LNPSN1, NESS1, LESSE1, LESSD1,
& KXN, KYN, KZN, KMAPEL,
& KIDELB, KNELB, KNLNK, KNATR, KLINK, KATRIB,
& KIDNS, KNNNS, KIXNNS, KLTNNS, KFACNS,
& KIDSS, KNESS, KNDSS, KIXESS, KIXDSS, KLTESS, kltsss,
& kltsnc, kfacss, NQAREC, QAREC, NINFO, INFREC, KNMLB,
& KNMBK, KNMNS, KNMSS, USESDF, *150)
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 140
100 CONTINUE
C --Save the length of the LINK array for later
CALL MDFIND ('LINK', IDUM, LLINK1)
C --Open and read the second database
WRITE (*, *)
110 CONTINUE
CALL GETINP (0, 0, 'Next input file> ', FILNAM, IOSTAT)
IF (IOSTAT .LT. 0) GOTO 150
CALL OUTLOG (KLOG, 1, 0, FILNAM, IDUM, RDUM)
TWODB = (FILNAM .NE. ' ')
IF (TWODB) THEN
CALL RDGEN (A, IA, C, .TRUE., FILNAM,
& TITLE2, NDIM2, NUMNP2, NUMEL2, NELBL2,
& NNPS2, LNPSN2, NESS2, LESSE2, LESSD2,
& KXN, KYN, KZN, KMAPEL,
& KIDELB, KNELB, KNLNK, KNATR, KLINK, KATRIB,
& KIDNS, KNNNS, KIXNNS, KLTNNS, KFACNS,
& KIDSS, KNESS, KNDSS, KIXESS, KIXDSS, KLTESS, kltsss,
& kltsnc, kfacss, NQAREC, QAREC, NINFO, INFREC, KNMLB,
& KNMBK, KNMNS, KNMSS, USESDF, *110)
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 140
IF (NDIM .NE. NDIM2) THEN
CALL PRTERR ('FATAL', 'Number of dimensions must match')
GOTO 110
END IF
call CHKTOP(NELBL2, C(KNMLB), COMTOP)
ELSE
TITLE2 = ' '
NUMNP2 = 0
numel2 = 0
nelbl2 = 0
nnps2 = 0
lnpsn2 = 0
ness2 = 0
lesse2 = 0
comtop = 'MULTIPLE_TOPOLOGIES'
END IF
C --Add an offset to the nodal point and element side set pointers
C --for the second database
IF (TWODB) THEN
CALL RENIX (NNPS2, LNPSN1, -999, IA(KIXNNS+NNPS1))
CALL RENIX (NESS2, LESSE1, -999, IA(KIXESS+NESS1))
CALL RENIX (NESS2, LESSD1, -999, IA(KIXDSS+NESS1))
END IF
C --Combine the nodes
NEWNP = NUMNP1 + NUMNP2
IF (TWODB) THEN
NMAT = 0
120 CONTINUE
xoff = 0.0
yoff = 0.0
zoff = 0.0
xscl = 1.0
yscl = 1.0
zscl = 1.0
rot3d = .false.
CALL IRENNP (A, NNPS1, NNPS2, IA(KIDNS), IA(KNNNS),
& REN, MATNS1, MATNS2, TOLER, CLOSE, MATMAT,
$ XSCL, YSCL, ZSCL, XOFF, YOFF, ZOFF, NDIM, IEXPCT)
IF (ROT3D) call dorot(ndim, numnp2, a(kxn+numnp1),
$ a(kyn+numnp1), a(kzn+numnp1),
$ rotmat, rotcen)
if (xoff .ne. 0.0 .or. xscl .ne. 1.0) then
call offset( xoff, xscl, a(kxn+numnp1), numnp2)
write (string, 9000) 'X', xscl, 'X', xoff
call sqzstr(string, lstr)
call prterr('CMDSPEC', string(:lstr))
end if
if (yoff .ne. 0.0 .or. yscl .ne. 1.0) then
call offset( yoff, yscl, a(kyn+numnp1), numnp2)
write (string, 9000) 'Y', yscl, 'Y', yoff
call sqzstr(string, lstr)
call prterr('CMDSPEC', string(:lstr))
end if
if ((zoff .ne. 0.0 .or. zscl .ne. 1.0) .and. ndim .eq. 3) then
call offset( zoff, zscl, a(kzn+numnp1), numnp2)
write (string, 9000) 'Z', zscl, 'Z', zoff
call sqzstr(string, lstr)
call prterr('CMDSPEC', string(:lstr))
else
zoff = 0.0
zscl = 1.0
end if
IF (XSCL * YSCL * ZSCL .LT. 0.0) THEN
kidel2 = kidelb + nelbl1
knelb2 = knelb + nelbl1
knlnk2 = knlnk + nelbl1
klink2 = klink + llink1
knmlb2 = knmlb + MXSTLN*nelbl1
CALL DBMIRR (1, NELBL2, IA(KIDEL2), IA(KNELB2), IA(KNLNK2),
* IA(KLINK2), C(KNMLB2), NDIM, NONQUD)
C ... Note that at this point, the index arrays have already been offset
C for the second database, so the arrays containing lists of
C nodes/dist-fact are passed in with no offset.
CALL MIRSS (NESS2, LESSE2, LESSD2,
* IA(KIDSS+NESS1), IA(KNESS+NESS1), IA(KNDSS+NESS1),
* IA(KIXESS+NESS1), IA(KIXDSS+NESS1), IA(KLTESS),
* IA(KLTSSS), IA(KLTSNC), A(KFACSS),
* USESDF, NONQUD, COMTOP)
END IF
IF (REN) THEN
IF (NMAT .LE. 0) THEN
CALL MDRSRV ('IXNP2', KIXNP2, NUMNP2)
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 140
END IF
CALL MDRSRV ('IX1', KIX1, NUMNP1)
CALL MDRSRV ('IX2', KIX2, NUMNP2)
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 140
if (.not. MATMAT) then
CALL MATXYZ (NDIM,
& MATNS1, MATNS2, IA(KNNNS), IA(KIXNNS), IA(KLTNNS),
& NUMNP1, A(KXN), A(KYN), A(KZN),
& NUMNP2, A(KXN+NUMNP1), A(KYN+NUMNP1), A(KZN+NUMNP1),
& IA(KIX1), IA(KIX2), IA(KIXNP2), NMAT, TOLER, CLOSE,
$ IEXPCT)
else
kidel2 = kidelb + nelbl1
knelb2 = knelb + nelbl1
knlnk2 = knlnk + nelbl1
klink2 = klink + llink1
CALL MDRSRV ('IX3', KIX3, NUMNP1)
CALL MDRSRV ('IX4', KIX4, NUMNP2)
CALL MDSTAT (NERR, MEM)
CALL EXPXYZ (NDIM,
& MATNS1, MATNS2, IA(KNNNS), IA(KIXNNS), IA(KLTNNS),
& NUMNP1, A(KXN), A(KYN), A(KZN),
& NUMNP2, A(KXN+NUMNP1), A(KYN+NUMNP1), A(KZN+NUMNP1),
& IA(KIX1), IA(KIX2), IA(KIX3), IA(KIX4), IA(KIXNP2),
$ NELBL1, IA(KIDELB), IA(KNELB), IA(KNLNK), IA(KLINK),
$ NELBL2, IA(KIDEL2), IA(KNELB2), IA(KNLNK2), A(KLINK2),
$ NMAT, TOLER, CLOSE, MATMAT)
CALL MDDEL ('IX3')
CALL MDDEL ('IX4')
end if
IF (NMAT .LE. 0) CALL MDDEL ('IXNP2')
CALL MDDEL ('IX1')
CALL MDDEL ('IX2')
GOTO 120
END IF
RENNP = (NMAT .GT. 0)
IF (.NOT. RENNP) KIXNP2 = 1
C --"Munch" the coordinates (second set)
IF (RENNP) THEN
NEWJNP = NUMNP2
CALL MUNXYZ (NDIM, NEWJNP, NUMNP1, IA(KIXNP2),
& A(KXN+NUMNP1), A(KYN+NUMNP1), A(KZN+NUMNP1))
NEWNP = NUMNP1 + NEWJNP
CALL MDLONG ('XN', KXN, NEWNP)
CALL MDLONG ('YN', KYN, NEWNP)
CALL MDLONG ('ZN', KZN, NEWNP)
END IF
IF (RENNP) THEN
IOFFNP = -999
ELSE
IOFFNP = NUMNP1
END IF
C --Renumber the element block nodes (second set)
CALL RENELB (NELBL2, IOFFNP, IA(KIXNP2),
& IA(KNELB+NELBL1), IA(KNLNK+NELBL1), IA(KLINK+LLINK1))
C --Renumber the nodal point set nodes (second set)
CALL RENIX (LNPSN2, IOFFNP, IA(KIXNP2), IA(KLTNNS+LNPSN1))
IF (RENNP) CALL MDDEL ('IXNP2')
END IF
C End of IF(TWODB)
C --Initialize items for output database
TITLE = TITLE1
NEWELB = NELBL1 + NELBL2
NEWEL = NUMEL1 + NUMEL2
NEWNPS = NNPS1 + NNPS2
NEWNNL = INTADD (NNPS1+NNPS2, IA(KNNNS))
NEWESS = NESS1 + NESS2
NEWSEL = INTADD (NESS1+NESS2, IA(KNESS))
NEWSDL = INTADD (NESS1+NESS2, IA(KNDSS))
C --Set up status arrays for user manipulation of element blocks and sets
CALL MDRSRV ('IELBST', KIELBS, NEWELB)
CALL MDRSRV ('INPSST', KINPSS, NEWNPS)
CALL MDRSRV ('IESSST', KIESSS, NEWESS)
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 140
C --Allow user to change element blocks and sets
CALL COMAND (A,
& IA(KIELBS), IA(KIDELB), IA(KNELB), IA(KNLNK), IA(KNATR),
& C(KNMLB), IA(KINPSS), IA(KIDNS), IA(KNNNS),
& IA(KIESSS), IA(KIDSS), IA(KNESS), DONE, *150)
C --"Munch" the element blocks
I = INTCNT (0, IA(KIELBS), NEWELB)
RENEL = (I .LT. NEWELB)
IF (RENEL) THEN
CALL MDRSRV ('IXEL', KIXEL, NEWEL)
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 140
CALL MDFIND ('LINK', IDUM, LLNK)
CALL MDRSRV ('LINKO', KLINKO, LLNK)
CALL MDFIND ('ATRIB', IDUM, LATR)
CALL MDRSRV ('ATRIBO', KATRO, LATR)
CALL MDRSRV ('IXELB', KIXELB, NEWELB)
CALL MDRSRV ('JNELB', KJNELB, NEWELB)
CALL MDRSRV ('ISCR', KISCR, NEWELB)
CALL MCFIND ('NAMBK', IDUM, LNAM)
CALL MCRSRV ('NAMSCR', KNMSC, LNAM)
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 140
CALL MUNELB (NEWELB, IA(KIELBS), NEWEL,
& 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(KNMLB), C(KNMBK), C(KNMSC), LLINK, LATRIB)
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)
END IF
CALL MDDEL ('IELBST')
C --Mark if any elements are deleted
DELEL = NEWEL .LT. (NUMEL1 + NUMEL2)
IF (DELEL) THEN
C --Make up an index of nodes in the existing element blocks
CALL MDRSRV ('IXNP', KIXNP, NEWNP)
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 140
N = NEWNP
CALL ZMFIXD (NEWELB, IA(KNELB), IA(KNLNK), IA(KLINK),
& N, IA(KIXNP))
DELNP = (N .LT. NEWNP)
IF (.NOT. DELNP) THEN
CALL MDDEL ('IXNP')
END IF
ELSE
DELNP = .FALSE.
END IF
C --Squeeze the coordinates
IF (DELNP) THEN
CALL ZMXYZ (NDIM, NEWNP, IA(KIXNP),
& A(KXN), A(KYN), A(KZN))
CALL MDLONG ('XN', KXN, NEWNP)
CALL MDLONG ('YN', KYN, NEWNP)
CALL MDLONG ('ZN', KZN, NEWNP)
END IF
C --Renumber the element map
c$$$
c$$$ IF (TWODB) THEN
c$$$ CALL RENIX (NUMEL2, NUMEL1, IDUM, IA(KMAPEL+NUMEL1))
c$$$ END IF
c$$$
c$$$ IF (RENEL) THEN
c$$$ CALL RENIX (NUMEL1+NUMEL2, -999, IA(KIXEL), IA(KMAPEL))
c$$$ END IF
c$$$
c$$$C --Squeeze the element map
c$$$
c$$$ IF (DELEL) THEN
c$$$ NEW = NUMEL1+NUMEL2
c$$$ CALL ZMMAP (NEW, IA(KMAPEL))
c$$$
c$$$ CALL MDLONG ('MAPEL', KMAPEL, NEW)
c$$$ END IF
C ... The above code assumes that the element map is a permutation of
C the sequence (1..numel). For example, if an optimizer has been
C run on the input databases. It will fail if the map contains
C values >numel which can happen in some instances. Since
C an optimization would have to be redone for the combined mesh and
C there is no good way to ensure that combining 2 or more arbitrary
C maps will give unique ids, we just punt and create a map which is
C 1..numel. Since we don't need it until output, we allocate and
C create it at the expmap call.
C --Renumber the element block nodes
IF (DELNP) THEN
CALL RENELB (NEWELB, -999, IA(KIXNP),
& IA(KNELB), IA(KNLNK), IA(KLINK))
END IF
C --Renumber the nodal point set nodes
IF (DELNP) THEN
CALL RENIX (LNPSN1+LNPSN2, -999, IA(KIXNP), IA(KLTNNS))
END IF
C --Renumber the element side set elements
IF (TWODB) THEN
CALL RENIX (LESSE2, NUMEL1, IDUM, IA(KLTESS+LESSE1))
END IF
IF (RENEL) THEN
CALL RENIX (LESSE1+LESSE2, -999, IA(KIXEL), IA(KLTESS))
END IF
IF (RENEL) THEN
CALL MDDEL ('IXEL')
END IF
C --"Munch" the nodal point sets
I = INTCNT (0, IA(KINPSS), NEWNPS)
IF ((I .LT. NEWNPS) .OR. DELNP) THEN
CALL MDLONG ('LTNNPS', KLTNNS, NEWNNL)
CALL MDLONG ('FACNPS', KFACNS, NEWNNL)
CALL MDRSRV ('LTNNPO', KLTNNO, NEWNNL)
CALL MDRSRV ('FACNPO', KFACNO, NEWNNL)
CALL MDRSRV ('IXNNPO', KIXNNO, NEWNPS)
CALL MDRSRV ('NNNPO', KNNNO, NEWNPS)
CALL MDRSRV ('ISCR', KISCR, NEWNPS)
call mdrsrv ('nodscr', kndscr, newnp)
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 140
CALL MUNNPS (NEWNPS, IA(KINPSS), NEWNNL,
& IA(KIDNS), IA(KNNNS), IA(KIXNNS), IA(KLTNNS), A(KFACNS),
& IA(KLTNNO), A(KFACNO), IA(KIXNNO), IA(KNNNO), IA(KISCR),
* IA(KNDSCR), NEWNP)
CALL MDDEL ('LTNNPO')
CALL MDDEL ('FACNPO')
CALL MDDEL ('IXNNPO')
CALL MDDEL ('NNNPO')
CALL MDDEL ('ISCR')
call mddel ('nodscr')
C --Squeeze the nodal point sets
IF (DELNP) THEN
CALL ZMNPS (NEWNPS, NEWNNL,
& IA(KIDNS), IA(KNNNS), IA(KIXNNS), IA(KLTNNS), A(KFACNS))
END IF
CALL MDLONG ('IDNPS', KIDNS, NEWNPS)
CALL MDLONG ('NNNPS', KNNNS, NEWNPS)
CALL MDLONG ('IXNNPS', KIXNNS, NEWNPS)
CALL MDLONG ('LTNNPS', KLTNNS, NEWNNL)
CALL MDLONG ('FACNPS', KFACNS, NEWNNL)
END IF
CALL MDDEL ('INPSST')
C --"Munch" the element side sets
I = INTCNT (0, IA(KIESSS), NEWESS)
IF ((I .LT. NEWESS) .OR. DELEL) THEN
CALL MDLONG ('LTEESS', KLTESS, NEWSEL)
CALL MDRSRV ('LTEESO', KLTESO, NEWSEL)
CALL MDRSRV ('LTSSO', KLTSSO, NEWSEL)
CALL MDRSRV ('FACS0', KFACS0, NEWSDL)
CALL MDRSRV ('IXEESO', KIXESO, NEWESS)
CALL MDRSRV ('IXEDS0', KIXDS0, NEWESS)
CALL MDRSRV ('NEESO', KNESO, NEWESS)
CALL MDRSRV ('NEDS0', KNDS0, NEWESS)
CALL MDRSRV ('ISCR', KISCR, NEWESS)
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 140
CALL MUNESS (NEWESS, IA(KIESSS), NEWSEL, NEWSDL,
& 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), USESDF)
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 MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 140
C --Squeeze the element side sets
IF (DELEL) THEN
CALL ZMESS (NEWESS, NEWSEL, NEWSDL,
& IA(KIDSS), IA(KNESS), IA(KNDSS), IA(KIXESS),
* IA(KIXDSS), IA(KLTESS), IA(KLTSSS), IA(KLTSNC),
* A(KFACSS), USESDF)
END IF
CALL MDLONG ('IDESS', KIDSS, NEWESS)
CALL MDLONG ('NEESS', KNESS, NEWESS)
CALL MDLONG ('IXEESS', KIXESS, NEWESS)
CALL MDLONG ('LTEESS', KLTESS, NEWSEL)
CALL MDLONG ('LTSESS', KLTSSS, NEWSEL)
CALL MDLONG ('FACESS', KFACSS, NEWSDL)
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 140
END IF
CALL MDDEL ('IESSST')
IF (DELNP) THEN
CALL MDDEL ('IXNP')
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 140
END IF
C --Find out if done processing (MOVED TO COMAND -- EXIT/ADD/FINISH)
IF (.NOT. DONE) THEN
numnp1 = newnp
numel1 = newel
nelbl1 = newelb
nnps1 = newnps
lnpsn1 = newnnl
ness1 = newess
lesse1 = newsel
lessd1 = newsdl
C ... Reset array sizes to match current combined database
call mdlong('XN', KXN, newnp)
call mdlong('YN', KYN, newnp)
call mdlong('ZN', KZN, newnp)
C call mdlong('MAPEL', KMAPEL, newel)
call mdlong('IDELB', KIDELB, newelb)
call mdlong('IDNPS', KIDNS, newnps)
call mdlong('LTNNPS', KLTNNS, newnnl)
call mdlong('IDESS', KIDSS, newess)
call mdlong('LTEESS', KLTESS, newsel)
CALL MDSTAT (NERR, MEM)
IF (NERR .GT. 0) GOTO 140
GOTO 100
END IF
C --Write out the new database
130 CONTINUE
IF (DONE) THEN
WRITE (*, *)
CALL GETINP (0, 0, 'Output file> ', FILNAM, IOSTAT)
CALL OUTLOG (KLOG, 1, 0, FILNAM, IDUM, RDUM)
IF (IOSTAT .LT. 0) GOTO 150
IF (FILNAM .EQ. ' ') GOTO 130
C --Write the QA records
IF (NQAREC .LT. MAXQA) THEN
NQAREC = NQAREC + 1
QAREC(1,NQAREC) = QAINFO(1)
QAREC(2,NQAREC) = QAINFO(3)
QAREC(3,NQAREC) = QAINFO(5)
QAREC(4,NQAREC) = QAINFO(6)
END IF
ELSE
FILNAM = '%gjoin'
END IF
CALL WRGEN (A, A, FILNAM, TITLE, NDIM, NEWNP, NEWEL, NEWELB,
& NEWNPS, NEWNNL, NEWESS, NEWSEL, NEWSDL,
& 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, C(KNMLB), L64BIT, NC4,
& C(KNMBK), C(KNMNS), C(KNMSS), *140)
FIRST = .FALSE.
IF (.NOT. DONE) GOTO 80
GOTO 150
140 CONTINUE
CALL MEMERR
GOTO 150
150 CONTINUE
call mdfree()
CALL WRAPUP (QAINFO(1))
call addlog (QAINFO(1)(:lenstr(QAINFO(1))))
OPEN (UNIT=9, FILE='%gjoin', FORM='unformatted',
& STATUS='old', IOSTAT=IERR)
IF (IERR .EQ. 0) THEN
CLOSE (9, STATUS='DELETE')
END IF
9000 format (A1,'new = ',1pe10.3,' * ',A1,'old + ',1pe10.3)
END
C...Check whether model contains elements of a single topology.
C This is currently used in the sideset mirroring code
subroutine chktop(nelblk, namelb, comtop)
include 'exodusII.inc'
integer nelblk
character*(MXSTLN) namelb(nelblk)
character*(MXSTLN) comtop
comtop = namelb(1)
do 10 i=2, nelblk
if (namelb(i) .ne. comtop) then
comtop = 'MULTIPLE_TOPOLOGIES'
return
end if
10 continue
return
end