fvbric01.F File Reference

#include "implicit_f.inc"

Go to the source code of this file.

Functions/Subroutines
subroutine	fvbric01 (ibuf, elem, ntgi, nb_node, nbric, ixs, tbric, tfac)

Function/Subroutine Documentation

fvbric01()

subroutine fvbric01	(	integer, dimension(*), intent(in)	ibuf,
		integer, dimension(3, ntgi), intent(in)	elem,
		integer, intent(in)	ntgi,
		integer, intent(in)	nb_node,
		integer, intent(in)	nbric,
		integer, dimension(nixs, *), intent(in)	ixs,
		integer, dimension(2, nbric), intent(in)	tbric,
		integer, dimension(12, nbric), intent(inout)	tfac )

Definition at line 32 of file fvbric01.F.

C-----------------------------------------------  
C     D e s c r i p t i o n
C-----------------------------------------------     
C     Find brick faces connected to internal airbag surface.
C     Faces are flagged -2 in th TFAC array.
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE groupdef_mod
      use element_mod , only : nixs      
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"     
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
C     NIXS
C     NUMELS
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER, INTENT(IN) :: NBRIC, NTGI, NB_NODE, TBRIC(2, NBRIC), IXS(NIXS, *)
      INTEGER, INTENT(IN) :: IBUF(*), ELEM(3, NTGI)
      INTEGER, INTENT(INOUT) :: TFAC(12, NBRIC)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: II, KK, KKK, KKKK, JJ, CONNECT_MAX, NODEID, COUNT, ELID, ELID1
      INTEGER :: NSEG, IFACE, ITYPE, NNODE, NSURFNODE, SUM
      INTEGER, DIMENSION(:), ALLOCATABLE :: IFLAG
      INTEGER, DIMENSION(:, :), ALLOCATABLE :: N_E_CONNECT, N_E_CONNECT_LOCID
      INTEGER, TARGET :: REDIRT(4), REDIRP(6), REDIRB(8), REDIRPY(5), 
     .     NOD8(6), NOD3(4), NOD6(5), NOD5(5),
     .     FAC8(4,6), FAC4(3,4), FAC6(4,5), FAC5(4,5), NFACE(4)
      INTEGER, DIMENSION(:), POINTER :: REDIR, NOD
      INTEGER, DIMENSION(:,:), POINTER :: FAC
      DATA fac4 /1,5,3,
     .           3,5,6,
     .           6,5,1,
     .           1,3,6/
      DATA fac8 /1,4,3,2,
     .           5,6,7,8,
     .           1,2,6,5,
     .           2,3,7,6,
     .           3,4,8,7,
     .           4,1,5,8/
      DATA fac6 /1,3,2,0,
     .           5,6,7,0,
     .           1,2,6,5,
     .           2,3,7,6,
     .           3,4,8,7/
      DATA nod6 /3,3,4,4,4/
      DATA nod8 /4,4,4,4,4,4/
      DATA nod3 /3,3,3,3/
      DATA fac5 /1,2,5,0,
     .           2,3,5,0,
     .           3,4,5,0,
     .           4,1,5,0,
     .           1,4,3,2/
      DATA nod5 /3,3,3,3,4/
      DATA nface/6,4,5,5/
      
      LOGICAL :: FACE_OK
      INTEGER, TARGET :: nothing(1,1)
     
C-----------------------------------------------
C     S o u r c e  l i n e s
C-----------------------------------------------
      redir => nothing(:,1)
      nod => nothing(:,1)
      fac => nothing
      nnode = 0
C     TETRA indirection
      redirt(1)=1
      redirt(2)=3
      redirt(3)=5
      redirt(4)=6
C     BRICK indirection
      DO kk = 1, 8
         redirb(kk) = kk
      ENDDO
C     PENTA indirection
      redirp(1)=1
      redirp(2)=2
      redirp(3)=3
      redirp(4)=5
      redirp(5)=6
      redirp(6)=7
C     PYRAMIDE indirection
      DO kk = 1, 5
         redirpy(kk) = kk
      ENDDO
     
 
C     Start 
 
      nseg = ntgi
 
C     Count maximum connectivity
      ALLOCATE(iflag(nb_node))
      iflag(1:nb_node) = 0
      DO ii = 1, nbric
         elid = tbric(1, ii)
         itype = tbric(2, ii)
         SELECT CASE(itype)
         CASE(1) 
C     Brick
            nnode = 8
            redir => redirb(1:8)
         CASE(2)
C     Tetra
            nnode = 4
            redir => redirt(1:4)
         CASE(3)
C     Penta
            nnode = 6
            redir => redirp(1:6)
         CASE(4)
C     Pyramide
            nnode = 5
            redir => redirpy(1:5)
         CASE DEFAULT
            nnode = -huge(nnode)
            redir => null()
            CALL arret(2)
         END SELECT
         DO kk = 1, nnode
            nodeid = ixs(1 + redir(kk), elid)
            iflag(nodeid) = iflag(nodeid) + 1
         ENDDO
      ENDDO
 
      connect_max = maxval(iflag(1:nb_node))
 
C     Node element connectivity
      ALLOCATE(n_e_connect(nb_node, connect_max + 1))
      ALLOCATE(n_e_connect_locid(nb_node, connect_max + 1))
      n_e_connect(1:nb_node, 1:connect_max + 1) = 0
      n_e_connect_locid(1:nb_node, 1:connect_max + 1) = 0
      DO ii = 1, nbric
         elid = tbric(1, ii)
         itype = tbric(2, ii)
         SELECT CASE(itype)
         CASE(1) 
C     Brick
            nnode = 8
            redir => redirb(1:8)
         CASE(2)
C     Tetra
            nnode = 4
            redir => redirt(1:4)
         CASE(3)
C     Penta
            nnode = 6
            redir => redirp(1:6)
         CASE(4)
C     Pyramide
            nnode = 5
            redir => redirpy(1:5)
         CASE DEFAULT
            CALL arret(2)
         END SELECT
         DO kk = 1, nnode
            nodeid = ixs(1 + redir(kk), elid)
            count = n_e_connect(nodeid, 1)
            count = count + 1
            n_e_connect(nodeid, 1) = count
            n_e_connect(nodeid, count + 1) = elid
            n_e_connect_locid(nodeid, count + 1) = ii
         ENDDO
      ENDDO
 
C     Reset IFLAG to 0
      iflag(1:nb_node) = 0
      count = 0
C     Find bricks connected to surface element
      DO ii = 1, nseg
         nsurfnode = 3
C     Flag surface nodes
         DO kk = 1, nsurfnode
            kkk = ibuf(elem(kk, ii))
            iflag(kkk) = 1
         ENDDO
         DO kk = 1, nsurfnode
            kkk = ibuf(elem(kk, ii))
            DO jj = 1, n_e_connect(kkk, 1)
               elid = n_e_connect(kkk, 1 + jj)
               itype = tbric(2, ii)
               SELECT CASE(itype)
               CASE(1) 
C     Brick
                  nnode = 8
                  redir => redirb(1:8)
                  fac => fac8(1:4, 1:6)
                  nod => nod8(1:6)
               CASE(2)
C     Tetra
                  nnode = 4
                  redir => redirt(1:4)
                  fac => fac4(1:3, 1:4)
                  nod => nod3(1:4)
               CASE(3)
C     Penta
                  nnode = 6
                  redir => redirp(1:6)
                  fac => fac6(1:4, 1:5)
                  nod => nod6(1:5)
               CASE(4)
C     Pyramide
                  nnode = 5
                  redir => redirpy(1:5)
                  fac => fac5(1:4, 1:5)
                  nod => nod5(1:5)
               CASE DEFAULT
                  CALL arret(2)
               END SELECT
               sum = 0
               DO kkkk = 1, nnode
                  nodeid = ixs(1 + redir(kkkk), elid)
                  sum = sum + iflag(nodeid)
               ENDDO
               IF (sum == nsurfnode) THEN
C     Find the corresponding face
                  face_ok = .false.
                  DO iface = 1, nface(itype)
                     sum = 0
                     DO kkkk = 1, nod(iface)
                        sum = sum + iflag(ixs(1 + fac(kkkk, iface), elid))
                     ENDDO
                     IF (sum == nsurfnode) THEN
                        face_ok = .true.
                     ENDIF
                     IF (face_ok) THEN
                        EXIT
                     ENDIF
                  ENDDO
                  IF (.NOT. face_ok) THEN
                     CALL arret(2)
                  ELSE
                     elid1 = n_e_connect_locid(kkk, 1 + jj)
                     tfac(2 * iface - 1, elid1) = -2
                     count = count + 1
                  ENDIF
               ENDIF
            ENDDO
         ENDDO
C     Unflag surface nodes element
         DO kk = 1, nsurfnode
            kkk = ibuf(elem(kk, ii))
            iflag(kkk) = 0               
         ENDDO                     
      ENDDO
 
C     Memory deallocation
      DEALLOCATE(iflag)
      DEALLOCATE(n_e_connect)
      DEALLOCATE(n_e_connect_locid)