1 : C DEDOU SOURCE MAGN 09/03/07 21:15:02 6318 2 : SUBROUTINE DEDOU 3 : C 4 : IMPLICIT INTEGER(I-N) 5 : IMPLICIT REAL*8 (A-H,O-Z) 6 : -INC CCOPTIO 7 : -INC SMELEME 8 : -INC SMCOORD 9 : C 10 : SEGMENT TTRAV 11 : INTEGER ILIS(NNOE) 12 : ENDSEGMENT 13 : SEGMENT XDET(NNOE) 14 : SEGMENT ICPR(XCOOR(/1)/(IDIM+1)) 15 : IF(IDIM.NE.2) THEN 16 : INTERR(1)=IDIM 16 : CALL ERREUR(709) 17 : RETURN 18 : ENDIF 19 : C 20 : C *** LECTURE DU MAILLAGE 21 : C 21 : CALL LIROBJ ('MAILLAGE',IPT1,1,IRETOU) 22 : IF(IERR.NE.0) RETURN 23 : SEGINI,MELEME=IPT1 24 : IF(LISOUS(/1).NE.0) THEN 25 : DO 1 I=1,LISOUS(/1) 26 : IPT3=LISOUS(I) 27 : SEGINI,IPT2=IPT3 28 : LISOUS(I)=IPT2 29 : SEGDES IPT2 30 : 1 CONTINUE 31 : ENDIF 32 : NBREF=0 33 : NBNN=NUM(/1) 34 : NBELEM=NUM(/2) 35 : NBSOUS=LISOUS(/1) 36 : SEGADJ MELEME 37 : SEGDES MELEME 38 : C 39 : C *** LECTURE DE LA LIGNE A DEDOUBLER 40 : C *** TTRAV CONTIENT LA LIGNE REORDONNEE ET ORIENTEE PAR LIGMAI 41 : C 41 : CALL LIROBJ ('MAILLAGE',IPT2,1,IRETOU) 42 : IF(IERR.NE.0) RETURN 42 : CALL LIGMAI(IPT2,TTRAV,0) 43 : SEGACT TTRAV 44 : C 45 : C *** CREATION DE LA DEUXIEME LEVRE 46 : C 47 : SEGINI,IPT5=IPT2 48 : C 49 : C *** ON REGARDE SI LA FISSURE EST DEBOUCHANTE 50 : C 50 : CALL ECROBJ('MAILLAGE',MELEME) 50 : CALL PRCONT 51 : IF(IERR.NE.0)RETURN 52 : SEGACT MELEME 53 : IF(LISREF(/1).NE.0) THEN 54 : NBREF=0 55 : NBNN=NUM(/1) 56 : NBELEM=NUM(/2) 57 : NBSOUS=LISOUS(/1) 58 : SEGADJ MELEME 59 : ENDIF 60 : SEGDES MELEME 60 : CALL LIROBJ('MAILLAGE',IPT2,1,IRETOU) 61 : SEGACT IPT2 62 : DO 4 IPASS=1,2 63 : IF(IPASS.EQ.1) THEN 64 : I=1 65 : ELSE 66 : I=ILIS(/1) 67 : ENDIF 68 : N1=ILIS(I) 69 : IPT3=IPT2 70 : DO 2 ISOU=1,MAX(1,IPT2.LISOUS(/1)) 71 : IF(IPT2.LISOUS(/1).NE.0) THEN 72 : IPT3=LISOUS(ISOU) 73 : SEGACT IPT3 74 : ENDIF 75 : DO 3 K=1,IPT3.NUM(/2) 76 : DO 3 J=1,IPT3.NUM(/1) 77 : IF(IPT3.NUM(J,K).EQ.N1) GO TO 21 78 : 3 CONTINUE 79 : 2 CONTINUE 80 : GOTO 4 81 : 21 CONTINUE 82 : C Le point N1 est une extremite qui appartient au contour 83 : C On rajoute a ILIS un autre point du contour 84 : DO 22 J=1,IPT3.NUM(/1) 85 : IF(IPT3.NUM(J,K).NE.N1) N2=IPT3.NUM(J,K) 86 : 22 CONTINUE 87 : NNOE=ILIS(/1)+1 88 : SEGADJ TTRAV 89 : IF(I.EQ.1) THEN 90 : DO 23 K=NNOE,2,-1 91 : ILIS(K)=ILIS(K-1) 92 : 23 CONTINUE 93 : ILIS(1)=N2 94 : ELSE 95 : ILIS(NNOE)=N2 96 : ENDIF 97 : 4 CONTINUE 98 : IF(IPT2.LISOUS(/1).NE.0) THEN 99 : DO 6 I=1,IPT2.LISOUS(/1) 100 : IPT3=LISOUS(I) 101 : SEGSUP IPT3 102 : 6 CONTINUE 103 : ENDIF 104 : SEGSUP IPT2 105 : C 106 : C *** AJOUT DE NOUVEAUX POINTS A MCOORD ET CREATION 107 : C *** D'UN ICPR DES NOEUDS A DEDOUBLER 108 : C 109 : NNOE=ILIS(/1) 110 : NDED=NNOE-2 111 : NNOEU=XCOOR(/1)/(IDIM+1) 112 : SEGINI ICPR 113 : NBPTS=NNOEU+NDED 114 : SEGADJ MCOORD 115 : DO 5 I=2,NNOE-1 116 : N1=ILIS(I) 117 : N2=I+NNOEU-1 118 : XCOOR((N2-1)*3+1)=XCOOR((N1-1)*3+1) 119 : XCOOR((N2-1)*3+2)=XCOOR((N1-1)*3+2) 120 : ICPR(N1)=I 121 : 5 CONTINUE 122 : ICPR(ILIS(1))=1 123 : ICPR(ILIS(NNOE))=NNOE 124 : C 125 : C *** CREATION DU TABLEAU XDET QUI CONTIENT LE 126 : C *** DETERMINANT DE DEUX VECTEURS CONSECUTIFS 127 : C 128 : SEGINI XDET 129 : N1=ILIS(1) 130 : N2=ILIS(2) 131 : VX1=XCOOR((N2-1)*3+1)-XCOOR((N1-1)*3+1) 132 : VY1=XCOOR((N2-1)*3+2)-XCOOR((N1-1)*3+2) 133 : DO 51 I=2,NNOE-1 134 : N3=ILIS(I+1) 135 : VX2=XCOOR((N3-1)*3+1)-XCOOR((N2-1)*3+1) 136 : VY2=XCOOR((N3-1)*3+2)-XCOOR((N2-1)*3+2) 137 : XDET(I)=VX1*VY2-VX2*VY1 138 : VX1=VX2 139 : VY1=VY2 140 : N1=N2 141 : N2=N3 142 : 51 CONTINUE 143 : C 144 : C *** RENUMEROTATION DES ELEMENTS DU MAILLAGE RESULTAT 145 : C 146 : SEGACT MELEME*MOD 147 : IPT1=MELEME 148 : DO 7 I=1,MAX(1,LISOUS(/1)) 149 : IF(LISOUS(/1).NE.0) THEN 150 : IPT1=LISOUS(I) 151 : SEGACT IPT1*MOD 152 : ENDIF 153 : DO 8 J=1,IPT1.NUM(/2) 154 : DO 9 K=1,IPT1.NUM(/1) 155 : N1=IPT1.NUM(K,J) 156 : IN1=ICPR(N1) 157 : IF(IN1.GT.1.AND.IN1.LT.NNOE) GOTO 10 158 : 9 CONTINUE 159 : GOTO 8 160 : C *** L'element contient un noeud N1 sur la ligne 161 : C *** N2 est le noeud suivant (sur la ligne), N3 le noeud precedent, 162 : C *** N4 un noeud de l'element qui n'appartient pas a la ligne. 163 : C *** Si l'element est "au-dessus" on va en 13 pour renumeroter. 164 : 10 N2=ILIS(IN1+1) 165 : N3=ILIS(IN1-1) 166 : DO 11 K=1,IPT1.NUM(/1) 167 : N4=IPT1.NUM(K,J) 168 : IF(ICPR(N4).EQ.0) GO TO 12 169 : 11 CONTINUE 170 : C *** Cas particulier ou tous les noeuds de l'element 171 : C *** appartiennent a la ligne 172 : N4=IPT1.NUM(1,J) 173 : N5=IPT1.NUM(2,J) 174 : N6=IPT1.NUM(3,J) 175 : IN1=MIN(ICPR(N4),ICPR(N5),ICPR(N6))+1 176 : IF(XDET(IN1).GE.0) GOTO 13 177 : GOTO 8 178 : C *** Cas general 179 : 12 VX1=XCOOR((N2-1)*3+1)-XCOOR((N1-1)*3+1) 180 : VY1=XCOOR((N2-1)*3+2)-XCOOR((N1-1)*3+2) 181 : VX2=XCOOR((N1-1)*3+1)-XCOOR((N3-1)*3+1) 182 : VY2=XCOOR((N1-1)*3+2)-XCOOR((N3-1)*3+2) 183 : VX3=XCOOR((N4-1)*3+1)-XCOOR((N1-1)*3+1) 184 : VY3=XCOOR((N4-1)*3+2)-XCOOR((N1-1)*3+2) 185 : DET1=VX1*VY3-VY1*VX3 186 : DET2=VX2*VY3-VY2*VX3 187 : IF(XDET(IN1).GE.0) THEN 188 : IF(DET1.GE.0.AND.DET2.GE.0.) GOTO 13 189 : ELSE 190 : IF(DET1.GT.0.OR.DET2.GT.0.) GOTO 13 191 : ENDIF 192 : GOTO 8 193 : 13 DO 14 K=1,IPT1.NUM(/1) 194 : N5=IPT1.NUM(K,J) 195 : IN5=ICPR(N5) 196 : IF(IN5.GT.1.AND.IN5.LT.NNOE) 197 : & IPT1.NUM(K,J)=IN5+NNOEU-1 198 : 14 CONTINUE 199 : 8 CONTINUE 200 : 7 CONTINUE 201 : IF(LISOUS(/1).NE.0) THEN 202 : DO 15 I=1,LISOUS(/1) 203 : IPT1=LISOUS(I) 204 : SEGDES IPT1 205 : 15 CONTINUE 206 : ENDIF 207 : C 208 : C *** RENUMEROTATION DE LA DEUXIEME LEVRE 209 : C 210 : IPT1=IPT5 211 : DO 16 I=1,MAX(1,IPT5.LISOUS(/1)) 212 : IF(IPT5.LISOUS(/1).NE.0) THEN 213 : IPT1=IPT5.LISOUS(I) 214 : SEGACT IPT1 215 : ENDIF 216 : DO 17 J=1,IPT1.NUM(/2) 217 : DO 18 K=1,IPT1.NUM(/1) 218 : N1=IPT1.NUM(K,J) 219 : IN1=ICPR(N1) 220 : IF(IN1.GT.1.AND.IN1.LT.NNOE) IPT1.NUM(K,J)=IN1+NNOEU-1 221 : 18 CONTINUE 222 : 17 CONTINUE 223 : 16 CONTINUE 224 : IF(IPT5.LISOUS(/1).NE.0) THEN 225 : DO 19 I=1,IPT5.LISOUS(/1) 226 : IPT1=IPT5.LISOUS(I) 227 : SEGDES IPT1 228 : 19 CONTINUE 229 : ENDIF 230 : SEGDES IPT5,MELEME 231 : SEGSUP TTRAV,XDET,ICPR 231 : CALL ECROBJ ('MAILLAGE',IPT5) 231 : CALL ECROBJ ('MAILLAGE',MELEME) 232 : RETURN 233 : END 234 : 235 : 236 : 237 : 238 : 239 : 240 : 241 : 242 :
© Cast3M 2003 - All rights reserved.
Disclaimer