Sources Esope | Cast3M

trjcub
C TRJCUB    SOURCE    CHAT      05/01/13    03:49:28     5004
      SUBROUTINE TRJCUB(IZNOEU,IZTRAV,IZAPAR,NPAPAR,J,IEL,INOELO,TLI)
C**********************************************************************
C
C   OBJET  : CE SOUS-PROGRAMME CALCULE L'APPARTENANCE DE POINTS A UN
C   -----    ELEMENT CUBE D'UN MAILLAGE M1.
C
C   ARGUMENTS:
C   ---------
C
C   ENTREE  :  IZNOEU = POINTEUR DU SEGMENT CONTENANT LES COORDONNEES
C                       ET LES NUMEROS DES NOEUDS DE L ELLAGE M1
C              IZTRAV = POINTEUR DU SEGMENT CONTENANT LES COORDONNEES
C                       DES POINTS DONT ON CHERCHE L'APPARTENANCE
C              IZAPAR = POINTEUR DU SEGMENT QUI CONTIENDRA LES
C                       APPARTENANCES
C              NPAPAR = NOMBRE DE POINTS APPARTENANT A UN ELEMENT
C              IEL    = NUMERO GLOBAL DE L'ELEMENT DANS LE MAILLAGE
C              J      = NUMERO DU POINT TRAITE
C
C***********************************************************************
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION TLI(*)
      DIMENSION XELTET(3,4),IDECUB(4,5),
     *          NUFACE(4,5),NUARET(6,5),X(3),NFACAR(6,5),NOEARE(8)
C
      SEGMENT IZAPAR
           INTEGER IAPAR(4,NPT2)
      ENDSEGMENT
C
      SEGMENT IZTRAV
           REAL*8  COOR(NDIM,NPART)
      ENDSEGMENT
      SEGMENT  IZNOEU
            REAL*8 XELE(IDIM,NOEL)
            INTEGER NOEGLO(NOEL)
      ENDSEGMENT
C
C
C
C
      DATA IDECUB/8,7,5,4, 1,2,4,5, 5,2,4,7, 6,5,7,2, 3,2,7,4/
      DATA NUFACE/5,2,0,6, 3,1,0,6, 0,0,0,0, 3,2,0,4, 1,4,0,5/
      DATA NUARET/7,4,12,0,0,0, 5,1,9,0,0,0, 0,0,0,0,0,0,
     *            8,3,10,0,0,0, 2,11,6,0,0,0/
      DATA NFACAR/5,6,6,2,6,5, 3,6,6,1,6,3, 3,6,2,1,5,4,
     *            3,4,4,2,4,3, 4,4,5,4,5,1/
C     DATA NOEARE/1,2,6,12,4,5,11,7/
      DATA NOEARE/1,2,6,12,4,8,11,7/
C
      IDIM=XELE(/1)
      NOEL=XELE(/2)
      INOELO=0
C
C***  DECOUPAGE DU CUBE EN 5 TETRAEDRES ET RECHERCHE DE L'APPARTENANCE
C***  DES POINTS A CHACUN DES TETRAEDRES.
C
      DO 40 I=1,5
          ITRI=I
C
          DO 20 K=1,4
              IN=IDECUB(K,ITRI)
              DO 10 L=1,3
                  XELTET(L,K)=XELE(L,IN)
  10          CONTINUE
  20      CONTINUE
C
C
          IF(IAPAR(1,J).NE.0) GO TO 9999
          X(1)=COOR(1,J)
          X(2)=COOR(2,J)
          X(3)=COOR(3,J)
          CALL APATET(X,XELTET,IELEM,IFATET,IARTET,INOTET,TLI)
          IF(IELEM.EQ.0) GO TO 40
C
C---  LE POINT APPARTIENT A L'ELEMENT
C
          NPAPAR=NPAPAR+1
          IAPAR(1,J)=IEL
C
C---  APPARTENANCE A UNE FACE DU CUBE
C
          IF(IFATET.EQ.0) GO TO 9999
          IAPAR(2,J)=NUFACE(IFATET,ITRI)
C
C---  APPARTENANCE A UNE ARETE DU CUBE
C
          IF(IARTET.EQ.0) GO TO 9999
          IARCUB=NUARET(IARTET,ITRI)
          IF(IAPAR(2,J).EQ.0.AND.IARTET.NE.0)
     *              IAPAR(2,J)=NFACAR(IARTET,ITRI)
          IAPAR(3,J)=IARCUB
C
C---  APPARTENANCE A UN NOEUD DU CUBE
C
          IF(INOTET.EQ.0) GO TO 9999
          INOELO=IDECUB(INOTET,ITRI)
          IF(IAPAR(3,J).EQ.0) IAPAR(3,J)=NOEARE(INOELO)
          IARCUB=IAPAR(3,J)
          IF(IAPAR(2,J).EQ.0) IAPAR(2,J)=NFACAR(IARTET,ITRI)
          IAPAR(4,J)=NOEGLO(INOELO)
          GO TO 9999
   40 CONTINUE
 9999 CONTINUE
      RETURN
      END