1 : C TRJCUB SOURCE CHAT 05/01/13 03:49:28 5004 2 : SUBROUTINE TRJCUB(IZNOEU,IZTRAV,IZAPAR,NPAPAR,J,IEL,INOELO,TLI) 3 : C********************************************************************** 4 : C 5 : C OBJET : CE SOUS-PROGRAMME CALCULE L'APPARTENANCE DE POINTS A UN 6 : C ----- ELEMENT CUBE D'UN MAILLAGE M1. 7 : C 8 : C ARGUMENTS: 9 : C --------- 10 : C 11 : C ENTREE : IZNOEU = POINTEUR DU SEGMENT CONTENANT LES COORDONNEES 12 : C ET LES NUMEROS DES NOEUDS DE L ELLAGE M1 13 : C IZTRAV = POINTEUR DU SEGMENT CONTENANT LES COORDONNEES 14 : C DES POINTS DONT ON CHERCHE L'APPARTENANCE 15 : C IZAPAR = POINTEUR DU SEGMENT QUI CONTIENDRA LES 16 : C APPARTENANCES 17 : C NPAPAR = NOMBRE DE POINTS APPARTENANT A UN ELEMENT 18 : C IEL = NUMERO GLOBAL DE L'ELEMENT DANS LE MAILLAGE 19 : C J = NUMERO DU POINT TRAITE 20 : C 21 : C*********************************************************************** 22 : IMPLICIT INTEGER(I-N) 23 : IMPLICIT REAL*8 (A-H,O-Z) 24 : DIMENSION TLI(*) 25 : DIMENSION XELTET(3,4),IDECUB(4,5), 26 : * NUFACE(4,5),NUARET(6,5),X(3),NFACAR(6,5),NOEARE(8) 27 : C 28 : SEGMENT IZAPAR 29 : INTEGER IAPAR(4,NPT2) 30 : ENDSEGMENT 31 : C 32 : SEGMENT IZTRAV 33 : REAL*8 COOR(NDIM,NPART) 34 : ENDSEGMENT 35 : SEGMENT IZNOEU 36 : REAL*8 XELE(IDIM,NOEL) 37 : INTEGER NOEGLO(NOEL) 38 : ENDSEGMENT 39 : C 40 : C 41 : C 42 : C 43 : DATA IDECUB/8,7,5,4, 1,2,4,5, 5,2,4,7, 6,5,7,2, 3,2,7,4/ 44 : DATA NUFACE/5,2,0,6, 3,1,0,6, 0,0,0,0, 3,2,0,4, 1,4,0,5/ 45 : DATA NUARET/7,4,12,0,0,0, 5,1,9,0,0,0, 0,0,0,0,0,0, 46 : * 8,3,10,0,0,0, 2,11,6,0,0,0/ 47 : DATA NFACAR/5,6,6,2,6,5, 3,6,6,1,6,3, 3,6,2,1,5,4, 48 : * 3,4,4,2,4,3, 4,4,5,4,5,1/ 49 : C DATA NOEARE/1,2,6,12,4,5,11,7/ 50 : DATA NOEARE/1,2,6,12,4,8,11,7/ 51 : C 52 : IDIM=XELE(/1) 53 : NOEL=XELE(/2) 54 : INOELO=0 55 : C 56 : C*** DECOUPAGE DU CUBE EN 5 TETRAEDRES ET RECHERCHE DE L'APPARTENANCE 57 : C*** DES POINTS A CHACUN DES TETRAEDRES. 58 : C 59 : DO 40 I=1,5 60 : ITRI=I 61 : C 62 : DO 20 K=1,4 63 : IN=IDECUB(K,ITRI) 64 : DO 10 L=1,3 65 : XELTET(L,K)=XELE(L,IN) 66 : 10 CONTINUE 67 : 20 CONTINUE 68 : C 69 : C 70 : IF(IAPAR(1,J).NE.0) GO TO 9999 71 : X(1)=COOR(1,J) 72 : X(2)=COOR(2,J) 73 : X(3)=COOR(3,J) 73 : CALL APATET(X,XELTET,IELEM,IFATET,IARTET,INOTET,TLI) 74 : IF(IELEM.EQ.0) GO TO 40 75 : C 76 : C--- LE POINT APPARTIENT A L'ELEMENT 77 : C 78 : NPAPAR=NPAPAR+1 79 : IAPAR(1,J)=IEL 80 : C 81 : C--- APPARTENANCE A UNE FACE DU CUBE 82 : C 83 : IF(IFATET.EQ.0) GO TO 9999 84 : IAPAR(2,J)=NUFACE(IFATET,ITRI) 85 : C 86 : C--- APPARTENANCE A UNE ARETE DU CUBE 87 : C 88 : IF(IARTET.EQ.0) GO TO 9999 89 : IARCUB=NUARET(IARTET,ITRI) 90 : IF(IAPAR(2,J).EQ.0.AND.IARTET.NE.0) 91 : * IAPAR(2,J)=NFACAR(IARTET,ITRI) 92 : IAPAR(3,J)=IARCUB 93 : C 94 : C--- APPARTENANCE A UN NOEUD DU CUBE 95 : C 96 : IF(INOTET.EQ.0) GO TO 9999 97 : INOELO=IDECUB(INOTET,ITRI) 98 : IF(IAPAR(3,J).EQ.0) IAPAR(3,J)=NOEARE(INOELO) 99 : IARCUB=IAPAR(3,J) 100 : IF(IAPAR(2,J).EQ.0) IAPAR(2,J)=NFACAR(IARTET,ITRI) 101 : IAPAR(4,J)=NOEGLO(INOELO) 102 : GO TO 9999 103 : 40 CONTINUE 104 : 9999 CONTINUE 105 : RETURN 106 : END 107 :
© Cast3M 2003 - All rights reserved.
Disclaimer