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.
188 lines
5.7 KiB
188 lines
5.7 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 MIRSS (IDESS, NEESS, IXEESS, LTEESS, LTSSS,
|
|
$ IBLOCK, BLKTYP, ALLONE, COMTOP)
|
|
C=======================================================================
|
|
|
|
C --*** MIRSS *** (GJOIN) Mirror element side sets
|
|
C -- Written by Greg Sjaardema
|
|
C --
|
|
C --MIRSS mirrors a side set and (if USESDF true) the distribution factors
|
|
C --applied to the nodes.
|
|
C --
|
|
C --Parameters:
|
|
C --
|
|
C -- NUMESS - IN/OUT - the number of element side sets
|
|
C -- LESSEL - IN/OUT - the length of the element side sets element list
|
|
C -- IDESS - IN/OUT - the element side set ID for each set
|
|
C -- NEESS - IN/OUT - the number of elements for each set
|
|
C -- IXEESS - IN/OUT - the index of the first element for each set
|
|
C -- LTEESS - IN/OUT - the elements for all sets
|
|
C -- LTSSS - IN/OUT - the sides for all sets
|
|
C -- ALLONE - IN - true if df are all unity, false if not all unity
|
|
|
|
include 'gp_params.blk'
|
|
include 'gp_dbnums.blk'
|
|
INTEGER IDESS(*) ! NUMESS
|
|
INTEGER NEESS(*) ! NUMESS
|
|
INTEGER IXEESS(*) ! NUMESS
|
|
INTEGER LTEESS(*) ! LESSEL
|
|
INTEGER LTSSS(*) ! LESSEL
|
|
INTEGER IBLOCK(*) ! NELBLK - gives index of last element in block
|
|
CHARACTER*(MXSTLN) BLKTYP(*)
|
|
|
|
LOGICAL ALLONE
|
|
CHARACTER*(*) COMTOP
|
|
|
|
C The routine now provides more checking and will return with a warning
|
|
C if applied to elements on other faces...
|
|
|
|
if (comtop(:8) .eq. 'MULTIPLE') THEN
|
|
DO NL = 1, NUMESS
|
|
iel = IXEESS(NL)
|
|
call mirs2(NEESS(NL), LTEESS(iel),
|
|
* LTSSS(iel), iblock, blktyp, nelblk, ndim)
|
|
end do
|
|
return
|
|
else
|
|
C ... comtop was not equal to "MULTIPLE_TOPOLOGIES", so
|
|
C at this point, the underlying element topology for all elements
|
|
C is the same....
|
|
DO NL = 1, NUMESS
|
|
iel = IXEESS(NL)
|
|
call mirs1(NEESS(NL), LTSSS(iel), blktyp(1), ndim)
|
|
end do
|
|
end if
|
|
IF (.NOT. ALLONE) THEN
|
|
CALL PRTERR ('WARNING',
|
|
* 'Mirroring of sideset distribution factors not supported')
|
|
END IF
|
|
|
|
RETURN
|
|
END
|
|
|
|
subroutine mirs1(numsid, side, type, ndim)
|
|
|
|
include 'gp_params.blk'
|
|
|
|
integer numsid
|
|
integer side(*)
|
|
CHARACTER*(MXSTLN) TYPE
|
|
|
|
if (type(:3) .eq. 'HEX') then
|
|
do i = 1, numsid
|
|
if (side(i) .le. 4) then
|
|
side(i) = 5 - side(i)
|
|
else
|
|
side(i) = side(i)
|
|
end if
|
|
end do
|
|
else if (type(:4) .eq. 'QUAD') then
|
|
do i = 1, numsid
|
|
side(i) = 5 - side(i)
|
|
end do
|
|
else if (type(:5) .eq. 'SHELL') then
|
|
return
|
|
else if (type(:5) .eq. 'TRUSS' .or.
|
|
$ type(:4) .eq. 'BEAM') then
|
|
return
|
|
else if (type(:3) .eq. 'TET') then
|
|
do i = 1, numsid
|
|
if (side(i) .eq. 3) then
|
|
side(i) = 1
|
|
else if (side(i) .eq. 1) then
|
|
side(i) = 3
|
|
end if
|
|
end do
|
|
else if (type(:3) .eq. 'TRI') then
|
|
C ... 'TRI' can be triangle or trishell
|
|
if (ndim .eq. 2) then
|
|
do i = 1, numsid
|
|
side(i) = 4 - side(i)
|
|
end do
|
|
end if
|
|
else if (type(:5) .eq. 'WEDGE') then
|
|
do i = 1, numsid
|
|
if (side(i) .eq. 3) then
|
|
side(i) = 1
|
|
else if (side(i) .eq. 1) then
|
|
side(i) = 3
|
|
end if
|
|
end do
|
|
end if
|
|
return
|
|
end
|
|
|
|
subroutine mirs2(numsid, elems, side,
|
|
$ iblock, blktyp, nelblk, ndim)
|
|
|
|
include 'gp_params.blk'
|
|
integer numsid, nelblk, elem
|
|
integer elems(*), side(*), iblock(*)
|
|
CHARACTER*(MXSTLN) BLKTYP(*)
|
|
|
|
lstelem = 0
|
|
lstblk = 1
|
|
iblk = 0
|
|
do i = 1, numsid
|
|
elem = elems(i)
|
|
if (elem .gt. lstelem) then
|
|
do j = lstblk, nelblk
|
|
if (elem .le. iblock(j)) then
|
|
iblk = j;
|
|
goto 30
|
|
end if
|
|
end do
|
|
30 continue
|
|
else
|
|
do j = 1, nelblk
|
|
if (elem .le. iblock(j)) then
|
|
iblk = j;
|
|
goto 20
|
|
end if
|
|
end do
|
|
20 continue
|
|
end if
|
|
lstelem = elem
|
|
lstblk = iblk
|
|
|
|
if (blktyp(iblk)(:3) .eq. 'HEX') then
|
|
if (side(i) .le. 4) then
|
|
side(i) = 5 - side(i)
|
|
else
|
|
side(i) = side(i)
|
|
end if
|
|
else if (blktyp(iblk)(:4) .eq. 'QUAD') then
|
|
side(i) = 5 - side(i)
|
|
else if (blktyp(iblk)(:5) .eq. 'SHELL') then
|
|
side(i) = side(i)
|
|
else if (blktyp(iblk)(:5) .eq. 'TRUSS' .or.
|
|
$ blktyp(iblk)(:4) .eq. 'BEAM') then
|
|
side(i) = side(i)
|
|
else if (blktyp(iblk)(:3) .eq. 'TET') then
|
|
if (side(i) .eq. 3) then
|
|
side(i) = 1
|
|
else if (side(i) .eq. 1) then
|
|
side(i) = 3
|
|
end if
|
|
else if (blktyp(iblk)(:3) .eq. 'TRI') then
|
|
C ... 'TRI' can be triangle or trishell
|
|
if (ndim .eq. 2) then
|
|
side(i) = 4 - side(i)
|
|
end if
|
|
else if (blktyp(iblk)(:5) .eq. 'WEDGE') then
|
|
if (side(i) .eq. 3) then
|
|
side(i) = 1
|
|
else if (side(i) .eq. 1) then
|
|
side(i) = 3
|
|
end if
|
|
end if
|
|
C ... If not in list above, assume that they need no adjustment.
|
|
end do
|
|
return
|
|
end
|
|
|