1 : C SFAC3D SOURCE CHAT 05/01/13 03:15:00 5004 2 : C ***************************************************************** 3 : C MODULE : ST (STRUCTURE DES DONNEES) 4 : C FICHIER : ST3D_STRUCT.F 5 : C OBJET : CONSULTATION, CONSTRUCTION ET MODIFICATION DE LA 6 : C STRUCTURE DE DONNE DU MAILLAGE 3D 7 : C FONCT. : 8 : C 9 : C SFAC3D : RECHERCHE LA FACE COMMUNE A 2 ELEMENTS 3D 10 : C 11 : C S3NBCO : CALCUL DU NOMBRE DE COTE D'UN ELEMENT 12 : C S3NBCF : CALCUL DU NOMBRE DE COTE DE LA FACE D'UN ELEMENT 13 : C 14 : C S3FDIA : FACE DIRECTE SUR UNE ARETE (INDICE RELATIF) 15 : C S3A2FA : ARETE COMMUNE A 2 FACES (INDICE RELATIF) 16 : C S3FASO : K SOMMETS DE LA FACE (INDICE RELATIF) 17 : C S3SOFA : K FACES AU SOMMET (INDICE RELATIF) 18 : C S3OPFA : ENTITE OPPOSEE A FACE (INDICE RELATIF) 19 : C 20 : C S3INVE : INVERSE L'ORIENTATION D'UN ELEMENT 3D 21 : C 22 : C AUTEUR : O. STAB 23 : C DATE : 03.95 24 : C TESTS : A FAIRE 25 : C 26 : C MODIFICATIONS : 27 : C AUTEUR : O.STAB 28 : C DATE : 26.06.96 29 : C OBJET : AJOUT SFAC3D (A TERMINER) 30 : C 31 : C MODIFICATIONS : 32 : C AUTEUR, DATE, OBJET : 33 : C 34 : C 35 : C ***************************************************************** 36 : C 37 : INTEGER FUNCTION SFAC3D( IT1, IT2, N1, N2, I1, I2 ) 38 : C ***************************************************************** 39 : C OBJET : RECHERCHE LA FACE COMMUME A 2 ELEMENTS 40 : C RENVOI LES INDICES I1 ET I2 CORRESPONDANTS AUX FRONTIERES 41 : C COMMUNES DES ELEMENTS IT1 ET IT2. 42 : C 43 : C EN ENTREE: 44 : C IT1,IT2: LES ELEMENTS A TESTER 45 : C N1 : (2..4) NOMBRE DE NOEUDS DE IT1 46 : C N2 : (2..4) NOMBRE DE NOEUDS DE IT2 47 : C 48 : C EN SORTIE: 49 : C I1,I2 : INDICES DES FRONTIERES COMMUNES 50 : C SFAC3D : 0 SI AUCUNE ARETE COMMUNE 51 : C -1 SI I1 ET I2 SONT PARCOURUS DANS LE MEME 52 : C SENS POUR IT1 ET IT2 53 : C 1 SI " " " " DANS LE SENS INVERSE 54 : C 55 : C CONDITION D'APPLICATION : TETRA, HEXA... 56 : C REMARQUE : N'UTILISE PAS LA STRUCTURE DE DONNEES MAILLAGE 57 : C N'EXPLOITE AUCUNE HYPOTHESE SUR IT1 ET IT2 58 : C ***************************************************************** 59 : IMPLICIT INTEGER(I-N) 60 : INTEGER IT1(N1), IT2(N2), N1,N2, I1, I2 61 : C 62 : INTEGER IT12(16),ISOM(16) 63 : INTEGER NBNF1(6),NBNF2(6),ISOMT1(4,6),ISOMT2(4,6) 64 : INTEGER I,IFF,IFF1,IFF2,NBF1,NBF2,INO,IDE,ISENS,NBNC,INO2 65 : INTEGER S3NBCO,S3FASO 66 : EXTERNAL S3NBCO,S3FASO 67 : C 68 : C WRITE(6,*) 'ON ENTRE DANS SFAC3D it1,it2 = ',IT1,IT2 69 : IDE = 3 70 : C WRITE(*,*) 'ON COMPARE :' 71 : C WRITE(*,*) (IT1(I),I=1,N1), 'ET ' 72 : C WRITE(*,*) (IT2(I),I=1,N2) 73 : C 74 : C COMPARER LA SIGNATURE DES 4 NOEUDS POUR OPTIMISER 75 : C -------------------------------------------------- 76 : DO 50 I=1,N1 77 : ISOM(I) = IT1(I) 78 : 50 CONTINUE 79 : DO 51 I=1,N2 80 : ISOM(I+N1) = IT2(I) 81 : 51 CONTINUE 81 : CALL KNUTA(N1+N2,ISOM) 82 : NBNC = 0 83 : DO 52 I=1,(N1+N2-1) 84 : IF(ISOM(I).EQ.ISOM(I+1))NBNC = NBNC+1 85 : 52 CONTINUE 86 : C WRITE(*,*) 'NOMBRE DE NOEUDS EN COMMUN :',NBNC 87 : C 88 : IF( NBNC.LT.3 )THEN 89 : SFAC3D = 0 90 : GOTO 9999 91 : ENDIF 92 : C 93 : IF(((N1.EQ.8).OR.(N2.EQ.8)).AND.(NBNC.EQ.3))THEN 94 : SFAC3D = 0 95 : GOTO 9999 96 : ENDIF 97 : C WRITE(6,*) 'IT1,IT2 = ',IT1,IT2 98 : C 99 : C --- IL Y A AU MOINS 3 NOEUDS EN COMMUN --- 100 : C IL FAUT TROUVER LES FACES ET LEURS INDICES 101 : C 102 : C --- LES FACES DE IT1 --- 103 : C 104 : C WRITE(*,*) 'PREMIER ELEMENT' 105 : ISENS = 1 106 : NBF1 = S3NBCO(N1) 107 : DO 61 IFF=1,NBF1 108 : NBNF1(IFF) = S3FASO(IFF,N1,ISENS,ISOMT1(1,IFF)) 109 : C WRITE(*,*) 'FACE :',IFF,' DE ',NBNF1(IFF),' SOMMETS =' 110 : C WRITE(*,*) (ISOMT1(INO,IFF),INO=1,3) 111 : C WRITE(*,*) 'ELEMENT =',(IT1(INO),INO=1,4) 112 : DO 60 INO=1,NBNF1(IFF) 113 : ISOMT1(INO,IFF)= IT1(ISOMT1(INO,IFF)) 114 : C WRITE(*,*) ISOMT1(INO,IFF) 115 : 60 CONTINUE 115 : C CALL KNUTA(NBNF1(IFF),ISOMT1(1,IFF)) 116 : 61 CONTINUE 117 : C 118 : C --- LES FACES DE IT2 --- 119 : C 120 : C WRITE(*,*) 'SECOND ELEMENT' 121 : NBF2 = S3NBCO(N2) 122 : DO 63 IFF=1,NBF2 123 : NBNF2(IFF) = S3FASO(IFF,N2,ISENS,ISOMT2(1,IFF)) 124 : C WRITE(*,*) 'FACE :',IFF,' DE ',NBNF2(IFF),' SOMMETS =' 125 : C WRITE(*,*) (ISOMT2(INO,IFF),INO=1,3) 126 : DO 62 INO=1,NBNF2(IFF) 127 : ISOMT2(INO,IFF)= IT2(ISOMT2(INO,IFF)) 128 : 62 CONTINUE 128 : C CALL KNUTA(NBNF2(IFF),ISOMT2(1,IFF)) 129 : 63 CONTINUE 130 : C 131 : C --- COMPARAISON --- 132 : C 133 : C WRITE(*,*) 'COMPARAISON' 134 : C WRITE(*,*) 'FACES = ',((ISOMT1(INO,IFF1),INO=1,3),'/',IFF1=1,4) 135 : C WRITE(*,*) 'FACES = ',((ISOMT2(INO,IFF1),INO=1,3),'/',IFF1=1,4) 136 : DO 80 IFF1=1,NBF1 137 : DO 75 IFF2=1,NBF2 138 : IF( NBNF1(IFF1).EQ.NBNF2(IFF2) )THEN 139 : INO = 1 140 : INO2 = 1 141 : C ---- ON CHERCHE LE DEBUT --------------------- 142 : 74 IF( ISOMT1(INO,IFF1).NE.ISOMT2(INO2,IFF2))THEN 143 : INO2 = INO2 + 1 144 : IF( INO2.GT.NBNF2(IFF2) ) GOTO 75 145 : GOTO 74 146 : ENDIF 147 : C ---- ON RECHERCHE LE SENS -------------------- 148 : IF( ISOMT1(INO+1,IFF1).NE. 149 : > ISOMT2(MOD(INO2,NBNF2(IFF2))+1,IFF2))THEN 150 : ISENS = -1 151 : ELSE 152 : ISENS = 1 153 : ENDIF 154 : C 155 : C ---- ON COMPARE 2 LISTES CIRCULAIRES --------- 156 : C 157 : 77 INO = INO+1 158 : IF(ISENS.EQ.1)THEN 159 : INO2 = MOD(INO2,NBNF2(IFF2)) + 1 160 : ELSE 161 : INO2 = NBNF2(IFF2) - MOD(NBNF2(IFF2)+1-INO2,NBNF2(IFF2)) 162 : ENDIF 163 : IF( ISOMT1(INO,IFF1).NE.ISOMT2(INO2,IFF2))GOTO 75 164 : C ---- 165 : IF( INO.EQ. NBNF1(IFF1) )THEN 166 : I1 = IFF1 167 : I2 = IFF2 168 : SFAC3D = -ISENS 169 : C WRITE(*,*) 'FACE COMMUNE :',I1,I2 170 : GOTO 9999 171 : ENDIF 172 : GOTO 77 173 : ENDIF 174 : 75 CONTINUE 175 : 80 CONTINUE 176 : C 177 : SFAC3D = 0 178 : C 179 : 9999 END 180 : 181 :
© Cast3M 2003 - All rights reserved.
Disclaimer