1 : C GENJO2 SOURCE AM 08/08/29 21:15:13 6146 2 : SUBROUTINE GENJO2 3 : C-------------------------------------------------------------------- 4 : C 5 : C MAIL1 = GENJ MAIL2 FLOT1; 6 : C 7 : C MAIL1 : MAILLAGE DE JOI2 8 : C MAIL2 : MAILLAGE DE QUA4 ET/OU DE TRI3 9 : C FLOT1 : TOLERANCE 10 : C 11 : C Pierre Pegon/JRC Ispra 12 : C + modif PP 8/98 pour accelerer la recherche des contours 13 : C-------------------------------------------------------------------- 14 : IMPLICIT INTEGER(I-N) 15 : IMPLICIT REAL*8 (A-H,O-Z) 16 : C 17 : -INC CCOPTIO 18 : -INC SMELEME 19 : -INC SMCOORD 20 : -INC CCGEOME 21 : -INC SMLENTI 22 : C 23 : SEGMENT,JOIGEN 24 : INTEGER P1(NCOTE),P2(NCOTE),SZONE(NCOTE),NELMT(NCOTE) 25 : INTEGER FLAG(NCOTE) 26 : ENDSEGMENT 27 : POINTEUR JOIGE1.JOIGEN 28 : C 28 : CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU) 29 : IF(IERR.NE.0) RETURN 29 : CALL LIRREE(XTOL,1,IRETOU) 30 : IF(IERR.NE.0) RETURN 31 : C 32 : C VERIFICATION DE LA DIMENSION 33 : C 34 : IF (IDIM.NE.2)THEN 35 : WRITE(IOIMP,*)'GENJO2: on n"est pas en 2D' 36 : RETURN 37 : ENDIF 38 : C 39 : C VERIFICATION DES TYPES D'ELEMENT (POUR LE MOMENT QUA4 ET TRI3) 40 : C ET CALCUL DU NOMBRE DE COTES 41 : C 42 : NCOTE=0 43 : SEGACT,IPT1 44 : NBSOUS=IPT1.LISOUS(/1) 45 : DO IE1=1,MAX(NBSOUS,1) 46 : IF(NBSOUS.EQ.0)THEN 47 : MELEME=IPT1 48 : ELSE 49 : MELEME=IPT1.LISOUS(IE1) 50 : SEGACT,MELEME 51 : ENDIF 52 : ILC=ITYPEL 53 : IF(ILC.NE.4.AND.ILC.NE.8)THEN 54 : WRITE(IOIMP,*)'GENJO2: type d"element incorrect' 55 : SEGDES,MELEME*NOMOD 56 : RETURN 57 : ELSE 58 : NCOTE=NCOTE+((ILC/4)+2)*ICOLOR(/1) 59 : ENDIF 60 : SEGDES,MELEME*NOMOD 61 : ENDDO 62 : C 63 : C REMPLISSAGE DU SEGMENT DES COTES 64 : C 65 : SEGACT,IPT1 66 : SEGINI,JOIGEN 67 : IJOI=0 68 : DO IE1=1,MAX(NBSOUS,1) 69 : IF(NBSOUS.EQ.0)THEN 70 : MELEME=IPT1 71 : ELSE 72 : MELEME=IPT1.LISOUS(IE1) 73 : SEGACT,MELEME 74 : ENDIF 75 : NC=(ITYPEL/4)+2 76 : NBEL=ICOLOR(/1) 77 : DO IE2=1,NBEL 78 : DO IE3=1,NC 79 : IJOI=IJOI+1 80 : P1(IJOI) =NUM(IE3,IE2) 81 : P2(IJOI) =NUM(MOD(IE3,NC)+1,IE2) 82 : SZONE(IJOI)=MIN(NBSOUS,IE1) 83 : NELMT(IJOI)=IE2 84 : FLAG(IJOI) =P1(IJOI)+P2(IJOI) 85 : ENDDO 86 : ENDDO 87 : ENDDO 88 : C 89 : C ELIMINATION DES DOUBLONS A NOEUDS IDENTIQUES 90 : C 91 : C NOUVELLE STRATEGIE AVEC TRI PREALABLE COMME DANS GENJO3 (8/98) 92 : C 93 : JG=NCOTE 94 : SEGINI,MLENTI,MLENT1 95 : DO IE1=1,NCOTE 96 : LECT(IE1)=IE1 97 : MLENT1.LECT(IE1)=FLAG(IE1) 98 : ENDDO 98 : CALL GENOR2(MLENT1.LECT,LECT,NCOTE) 99 : IFI=MLENT1.LECT(1) 100 : DO IE1=2,NCOTE 101 : IFF=MLENT1.LECT(IE1) 102 : IF(IFI.EQ.IFF)THEN 103 : JE1=LECT(IE1-1) 104 : IF(FLAG(JE1).NE.0)THEN 105 : DO IE2=IE1,NCOTE 106 : IFFF=MLENT1.LECT(IE2) 107 : IF(IFI.NE.IFFF)GOTO 10 108 : JE2=LECT(IE2) 109 : IF(FLAG(JE2).NE.0)THEN 110 : IF((P1(JE1).EQ.P1(JE2).AND.P2(JE1).EQ.P2(JE2)).OR. 111 : > (P1(JE1).EQ.P2(JE2).AND.P2(JE1).EQ.P1(JE2)))THEN 112 : FLAG(JE1)=0 113 : FLAG(JE2)=0 114 : GOTO 10 115 : ENDIF 116 : ENDIF 117 : ENDDO 118 : ENDIF 119 : ENDIF 120 : 10 IFI=IFF 121 : ENDDO 122 : SEGSUP,MLENTI,MLENT1 123 : C 124 : C CONCATENATION DE LA LISTE 125 : C 126 : NNCOTE=NCOTE 127 : NCOTE=0 128 : DO IE1=1,NNCOTE 129 : IF(FLAG(IE1).NE.0)NCOTE=NCOTE+1 130 : ENDDO 131 : SEGINI,JOIGE1 132 : IE2=0 133 : DO IE1=1,NNCOTE 134 : IF(FLAG(IE1).NE.0)THEN 135 : IE2=IE2+1 136 : JOIGE1.P1(IE2)=P1(IE1) 137 : JOIGE1.P2(IE2)=P2(IE1) 138 : JOIGE1.SZONE(IE2)=SZONE(IE1) 139 : JOIGE1.NELMT(IE2)=NELMT(IE1) 140 : JOIGE1.FLAG(IE2)=0 141 : ENDIF 142 : ENDDO 143 : SEGSUP,JOIGEN 144 : JOIGEN=JOIGE1 145 : C 146 : C DETERMINATION DES SEGMENTS AVEC VIS-A-VIS 147 : C 148 : DO IE1=1,NCOTE-1 149 : IF(FLAG(IE1).EQ.0)THEN 150 : IPR1 = (IDIM+1)*(P1(IE1)-1) 151 : XP1 = XCOOR(IPR1+1) 152 : YP1 = XCOOR(IPR1+2) 153 : IPR2 = (IDIM+1)*(P2(IE1)-1) 154 : XP2 = XCOOR(IPR2+1) 155 : YP2 = XCOOR(IPR2+2) 156 : DO IE2=IE1+1,NCOTE 157 : IF(FLAG(IE2).EQ.0)THEN 158 : IPPR1= (IDIM+1)*(P1(IE2)-1) 159 : XPP1 = XCOOR(IPPR1+1) 160 : YPP1 = XCOOR(IPPR1+2) 161 : IPPR2= (IDIM+1)*(P2(IE2)-1) 162 : XPP2 = XCOOR(IPPR2+1) 163 : YPP2 = XCOOR(IPPR2+2) 164 : DIST1=SQRT((XP1-XPP1)**2+(YP1-YPP1)**2) 165 : > +SQRT((XP2-XPP2)**2+(YP2-YPP2)**2) 166 : DIST2=SQRT((XP1-XPP2)**2+(YP1-YPP2)**2) 167 : > +SQRT((XP2-XPP1)**2+(YP2-YPP1)**2) 168 : C PP 2001 IF(DIST1.LT.XTOL.OR.DIST2.LT.XTOL)THEN 169 : IF(DIST1.LT.2*XTOL.OR.DIST2.LT.2*XTOL)THEN 170 : FLAG(IE1)=IE2 171 : FLAG(IE2)=IE1 172 : C PP 2001 IF(DIST2.LT.XTOL)THEN 173 : IF(DIST2.LT.2*XTOL)THEN 174 : IPDUM=P1(IE2) 175 : P1(IE2)=P2(IE2) 176 : P2(IE2)=IPDUM 177 : ENDIF 178 : GOTO 20 179 : ENDIF 180 : ENDIF 181 : ENDDO 182 : ENDIF 183 : 20 CONTINUE 184 : ENDDO 185 : C 186 : C CREATION DU MAILLAGE DE JOINT 187 : C 188 : NBNN=4 189 : NBREF=0 190 : NBSOUS=0 191 : NBELEM=0 192 : DO IE1=1,NCOTE 193 : IF(FLAG(IE1).NE.0)NBELEM=NBELEM+1 194 : ENDDO 195 : NBELEM=NBELEM/2 196 : SEGINI,IPT2 197 : IPT2.ITYPEL=12 198 : DO IE1=1,NBELEM 199 : IPT2.ICOLOR(IE1)=0 200 : ENDDO 201 : C 202 : C GENERATION DU MAILLAGE DE JOINT 203 : C 204 : IELEM=0 205 : DO IE1=1,NCOTE 206 : IF(FLAG(IE1).NE.0)THEN 207 : IELEM=IELEM+1 208 : * 209 : * premier barycentre 210 : * 211 : XG=0.D0 212 : YG=0.D0 213 : IF(SZONE(IE1).EQ.0)THEN 214 : MELEME=IPT1 215 : ELSE 216 : MELEME=IPT1.LISOUS(SZONE(IE1)) 217 : ENDIF 218 : DO IE3=1,NUM(/1) 219 : IPDUM=(IDIM+1)*(NUM(IE3,NELMT(IE1))-1) 220 : XG=XG+XCOOR(IPDUM+1) 221 : YG=YG+XCOOR(IPDUM+2) 222 : ENDDO 223 : XG=XG/NUM(/1) 224 : YG=YG/NUM(/1) 225 : * 226 : * 2 points le long du joint 227 : * 228 : IPR1 = (IDIM+1)*(P1(IE1)-1) 229 : XP1 = XCOOR(IPR1+1) 230 : YP1 = XCOOR(IPR1+2) 231 : IPR2 = (IDIM+1)*(P2(IE1)-1) 232 : XP2 = XCOOR(IPR2+1) 233 : YP2 = XCOOR(IPR2+2) 234 : * 235 : * second barycentre 236 : * 237 : IE2=FLAG(IE1) 238 : XGG=0.D0 239 : YGG=0.D0 240 : IF(SZONE(IE2).EQ.0)THEN 241 : MELEME=IPT1 242 : ELSE 243 : MELEME=IPT1.LISOUS(SZONE(IE2)) 244 : ENDIF 245 : DO IE3=1,NUM(/1) 246 : IPDUM=(IDIM+1)*(NUM(IE3,NELMT(IE2))-1) 247 : XGG=XGG+XCOOR(IPDUM+1) 248 : YGG=YGG+XCOOR(IPDUM+2) 249 : ENDDO 250 : XGG=XGG/NUM(/1) 251 : YGG=YGG/NUM(/1) 252 : * 253 : * produit vectoriel, et selon son signe... 254 : * 255 : XVECT=(XP2-XP1)*(YGG-YG)-(YP2-YP1)*(XGG-XG) 256 : * PPj IF(XVECT.GT.0)THEN 257 : IF(XVECT.LT.0)THEN 258 : IPT2.NUM(1,IELEM)=P1(IE1) 259 : IPT2.NUM(2,IELEM)=P2(IE1) 260 : IPT2.NUM(3,IELEM)=P2(IE2) 261 : IPT2.NUM(4,IELEM)=P1(IE2) 262 : ELSE 263 : IPT2.NUM(1,IELEM)=P2(IE1) 264 : IPT2.NUM(2,IELEM)=P1(IE1) 265 : IPT2.NUM(3,IELEM)=P1(IE2) 266 : IPT2.NUM(4,IELEM)=P2(IE2) 267 : ENDIF 268 : * 269 : * on efface les 2 cotes 270 : * 271 : FLAG(IE1)=0 272 : FLAG(IE2)=0 273 : ENDIF 274 : ENDDO 275 : C 276 : C DESTRUCTION, DESACTIVATION ET RETOUR A GIBIANE 277 : C 278 : SEGSUP,JOIGEN 279 : NBSOUS=IPT1.LISOUS(/1) 280 : DO IE1=1,MAX(NBSOUS,1) 281 : IF(NBSOUS.EQ.0)THEN 282 : MELEME=IPT1 283 : ELSE 284 : MELEME=IPT1.LISOUS(IE1) 285 : ENDIF 286 : SEGDES,MELEME*NOMOD 287 : ENDDO 288 : SEGDES,IPT2 288 : CALL ECROBJ('MAILLAGE',IPT2) 289 : C 290 : RETURN 291 : END 292 : 293 : 294 : 295 : 296 : 297 :
© Cast3M 2003 - All rights reserved.
Disclaimer