1 : C PROPER SOURCE GOUNAND 12/08/24 21:15:00 7488 2 : 3 : C----------------------------------------------------------------------- 4 : C Ce sous programme gere les operateurs 'PLUS', 'MOIN' et 'TOUR', 5 : C ainsi que les options 'TRAN' et 'ROTA' de de l'operateur 'DEDU' 6 : C 7 : C OBJ2 = OBJ1 'PLUS' POIN1 / CHPO1 ; 8 : C OBJ1 : type POINT, MAILLAGE, CHPOINT, MCHAML, MMODEL, RIGIDITE 9 : C 10 : C OBJ2 = OBJ1 'MOIN' POIN1 / CHPO1 ; 11 : C OBJ1 : type POINT, MAILLAGE, CHPOINT, MCHAML, MMODEL, RIGIDITE 12 : C 13 : C CHPO1 = GEO2 'MOIN' GEO1 ; 14 : C GEO2, GEO1 : type MAILLAGE, CHPO1 : type CHPO1 15 : C determination du CHPOINT dont les points support correspond aux 16 : C points de GEO1 et permettant d'obtenir GEO2 a partir de GEO1. 17 : C 18 : C OBJ2 = OBJ1 'TOUR' FLOT1 POIN1 (POIN2) ; 19 : C OBJ1 : type POINT, MAILLAGE, CHPOINT, MCHAML, MMODEL, (RIGIDITE ?) 20 : C Certaines composantes subissent egalement la rotation. 21 : C (Appel via tourne.eso - non disponible en DIMEnsion 1) 22 : C 23 : C OBJ2 = OBJ1 'DEDU' 'TRAN' GEO1 GEO2 ; 24 : C OBJ1 : type POINT, MAILLAGE, CHPOINT, MCHAML, MMODEL, RIGIDITE 25 : C GEO1, GEO2 : type MAILLAGE (GEO2 image de GEO1) 26 : C (Appel via dedu.eso) 27 : C 28 : C OBJ2 = OBJ1 'DEDU' FLOT1 POIN1 (POIN2 si 3D) 'ROTA' GEO1 GEO2 ; 29 : C OBJ1 : type POINT, MAILLAGE, CHPOINT, MCHAML, MMODEL, RIGIDITE 30 : C GEO1, GEO2 : type MAILLAGE (GEO2 image de GEO1 par la ROTAtion) 31 : C POIN1 (POIN2) : type POINT (centre ou axe de la rotation) 32 : C FLOT1 : type FLOTTANT (angle de rotation) 33 : C (Appel via dedu.eso - non disponible en DIMEnsion 1) 34 : C----------------------------------------------------------------------- 35 : C Remarques : 36 : C ----------- 37 : C Dans le cas des syntaxes particulieres (1) POIN2 = POIN1 'PLUS' VECT1 38 : C (ou POIN2 = POIN1 'MOIN' VECT1), et (2) POIN2 = POIN1 'TOUR' FLOT1 39 : C PT1 (PT2) , la densite du POIN2 obtenu est, dans le cas (1), la den- 40 : C site COURANTE definie via l'operateur 'DENSITE', et, dans le cas (2), 41 : C identique a celle du POIN1. 42 : C Pour toutes les autres types d'objets et syntaxes, la densite des 43 : C points transformes est identique a celle des points d'origine. 44 : C----------------------------------------------------------------------- 45 : C 11/1997 : KICH 46 : C 10/2003 : modifications pour le cas IDIM=1. 47 : * 07/2007 : PM initialisation de NBREF dans le cas d'un point en entrée 48 : c 07/2009 : BP pour DEDU 'TRAN' avec rigidite, DEDU3.eso teste si IPOIN1 = translation? 49 : C----------------------------------------------------------------------- 50 : 51 : SUBROUTINE PROPER(ITYP) 52 : 53 : IMPLICIT INTEGER(I-N) 54 : IMPLICIT REAL*8 (A-H,O-Z) 55 : 56 : -INC CCOPTIO 57 : -INC CCREEL 58 : -INC SMCOORD 59 : -INC SMELEME 60 : -INC CCGEOME 61 : -INC SMRIGID 62 : -INC SMCHPOI 63 : -INC SMMODEL 64 : -INC SMCHAML 65 : -INC SMTABLE 66 : 67 : 68 : DIMENSION Y(3) 69 : CHARACTER*4 MOT1 70 : CHARACTER*8 ITOPE 71 : 72 : COMMON / CTOURN / XPT1,YPT1,ZPT1,XV1,YV1,ZV1,XV2,YV2,ZV2, 73 : . XVEC,YVEC,ZVEC,ANGLE,ICLE 74 : 75 : SEGMENT ICPR(XCOOR(/1)/(IDIM+1)) 76 : SEGMENT ICP1(XCOOR(/1)/(IDIM+1)) 77 : SEGMENT MLITY 78 : CHARACTER*8 LITY2(NTY2) 79 : ENDSEGMENT 80 : SEGMENT IPOSI 81 : integer IPOSIT(mlotab) 82 : ENDSEGMENT 83 : 84 : C PILO : liste de pointeurs sur les objets DSOBJ a transformer 85 : SEGMENT PILO(0) 86 : SEGMENT DSOBJ 87 : INTEGER INIPOI,INIFIN 88 : CHARACTER*8 LETYP 89 : ENDSEGMENT 90 : 91 : C IPLMAIL : liste des maillages elementaires d'un objet a transformer 92 : SEGMENT IPLMAIL(0) 93 : 94 : C ITABEL : contient, initialement, tous les maillages elementaires du 95 : C maillage initial GEO1, puis tous les maillages elementaires et refe- 96 : C rence des objets initiaux qui ont deja ete transformes afin d'eviter 97 : C de les transporter plusieurs fois 98 : C INOUVEL : contient l'image des maillages elementaires et references 99 : C par la transformation changeant GEO1 en GEO2 100 : C GEO1 --> GEO2 et ITABEL(i) --> INOUVEL(i) 101 : SEGMENT ITABEL(0) 102 : SEGMENT INOUVEL(0) 103 : 104 : idimp1=IDIM+1 105 : ANGLE=0. 106 : 107 : C Signification de ITYP (argument de PROPER) : 108 : C - ITYP = 1 : operateur PLUS 109 : C - ITYP = 2 : operateur MOIN 110 : C - ITYP = 3 : operateur TOUR (via sp tourne.eso) 111 : C - ITYP = 4 : operateur DEDU 'TRAN' (via sp dedu.eso) 112 : C - ITYP = 5 : operateur DEDU 'ROTA' (via sp dedu.eso) 113 : IF ((ITYP.EQ.1).OR.(ITYP.EQ.4)) THEN 114 : ICLE=1 115 : ISENS=1 116 : ENDIF 117 : IF (ITYP.EQ.2) THEN 118 : ICLE=1 119 : ISENS=-1 120 : ENDIF 121 : IF ((ITYP.EQ.3).OR.(ITYP.EQ.5)) THEN 122 : ICLE=2 123 : C Lecture (obligatoire) de l'angle de rotation 123 : CALL LIRREE(FLO1,1,IRETOU) 124 : IF (IRETOU.EQ.0) THEN 124 : CALL ERREUR(884) 125 : RETURN 126 : ENDIF 127 : ANGLE=FLO1-INT(FLO1/360.)*360. 128 : IF (ANGLE.GT.180.) ANGLE=ANGLE-360. 129 : IF (ANGLE.LT.(-180.)) ANGLE=ANGLE+360. 130 : ANGLE=ANGLE*XPI/180. 131 : CO=COS(ANGLE) 132 : SI=SIN(ANGLE) 133 : ENDIF 134 : C Rappel : ICLE=2 (rotation) n'est disponible que si IDIM = 2 ou 3 135 : 136 : C Nombre d'objets definissant l'operation a effectuer 137 : IF ((ITYP.EQ.1).OR.(ITYP.EQ.2)) MINIOBJ=1 138 : IF ((ITYP.EQ.3).AND.(IDIM.EQ.2)) MINIOBJ=1 139 : IF ((ITYP.EQ.3).AND.(IDIM.GE.3)) MINIOBJ=2 140 : IF (ITYP.EQ.4) MINIOBJ=2 141 : IF ((ITYP.EQ.5).AND.(IDIM.EQ.2)) MINIOBJ=3 142 : IF ((ITYP.EQ.5).AND.(IDIM.GE.3)) MINIOBJ=4 143 : 144 : C Tableau des types d'objets pouvant etre transformes 145 : NTY2=6 146 : SEGINI MLITY 147 : LITY2(1)='POINT ' 148 : LITY2(2)='MAILLAGE' 149 : LITY2(3)='CHPOINT ' 150 : LITY2(4)='MMODEL ' 151 : LITY2(5)='MCHAML ' 152 : LITY2(6)='RIGIDITE' 153 : SEGDES MLITY 154 : ITOPE=' ' 155 : itab=0 156 : C Stockage dans le segment PILO (pointeur IP1) de tous les objets, 157 : C donnes en entree a l'operateur et dont le type est inclus dans MLITY 158 : C (type POINT,MAILLAGE,CHPOINT,MCHAML,MMODEL ou RIGIDITE) 158 : CALL EMPIL1(IP1,MLITY,IRETOU,itab,iposi) 159 : PILO=ip1 160 : segact pilo 161 : IF (IERR.NE.0) GO TO 100 162 : IF (IRETOU.EQ.20) THEN 163 : MOTERR(1:30) ='POINT ou MAILLAGE ou CHPOINT' 163 : CALL ERREUR(881) 164 : GOTO 100 165 : ENDIF 166 : 167 : PILO=IP1 168 : SEGACT PILO 169 : NIOBJ=PILO(/1) 170 : C Erreur si pas assez d'objets (pas d'objets a transformer de donner) 171 : IF (NIOBJ.LE.MINIOBJ) THEN 172 : MOTERR(1:30) =' d autres arguments ' 172 : CALL ERREUR(881) 173 : GOTO 100 174 : ENDIF 175 : 176 : C Lecture des MINIOBJ objets definissant la transformation a effectuer 177 : C ====================================================================== 178 : DSOBJ=nint(PILO(NIOBJ)) 179 : SEGACT DSOBJ 180 : ITOPE=LETYP 181 : IPOIN1=INIPOI 182 : SEGDES DSOBJ 183 : C Option DEDU 'TRAN' : 184 : C ---------------------- 185 : IF (ITYP.EQ.4) THEN 186 : C Syntaxe incorrecte : maillage GEO2 attendu 187 : IF (ITOPE.NE.'MAILLAGE') THEN 188 : MOTERR(1:30) ='un MAILLAGE ' 188 : CALL ERREUR(881) 189 : GOTO 100 190 : ENDIF 191 : IPT2=IPOIN1 192 : DSOBJ=nint(PILO(NIOBJ-1)) 193 : SEGACT DSOBJ 194 : IPT1=INIPOI 195 : ITOPE=LETYP 196 : SEGDES DSOBJ 197 : C Syntaxe incorrecte : maillage GEO1 attendu 198 : IF (ITOPE.NE.'MAILLAGE') THEN 199 : MOTERR(1:30) = 'un MAILLAGE ' 199 : CALL ERREUR(881) 200 : GOTO 100 201 : ENDIF 201 : CALL DEDU1(IPT1,IPT2,ICP1,ITABEL,INOUVEL,IPOIN1) 202 : IF (IERR.NE.0) GOTO 100 203 : ITOPE='CHPOINT ' 204 : ICPR=ICP1 205 : SEGACT ITABEL*MOD,INOUVEL*MOD 206 : ENDIF 207 : C Option DEDU 'ROTA' : 208 : C ---------------------- 209 : IF (ITYP.EQ.5) THEN 210 : C Syntaxe incorrecte : maillage GEO2 attendu 211 : IF (ITOPE.NE.'MAILLAGE') THEN 212 : MOTERR(1:30) ='un MAILLAGE ' 212 : CALL ERREUR(881) 213 : GOTO 100 214 : ENDIF 215 : IPT2=IPOIN1 216 : DSOBJ=nint(PILO(NIOBJ-1)) 217 : SEGACT DSOBJ 218 : IPT1=INIPOI 219 : ITOPE=LETYP 220 : SEGDES DSOBJ 221 : C Syntaxe incorrecte : maillage GEO1 attendu 222 : IF (ITOPE.NE.'MAILLAGE') THEN 223 : MOTERR(1:30) = 'un MAILLAGE ' 223 : CALL ERREUR(881) 224 : GOTO 100 225 : ENDIF 225 : CALL DEDU1(IPT1,IPT2,ICP1,ITABEL,INOUVEL,IPOIN1) 226 : IF (IERR.NE.0) GOTO 100 227 : DSOBJ=nint(PILO(NIOBJ-2)) 228 : SEGACT DSOBJ 229 : IPOIN1=INIPOI 230 : ITOPE=LETYP 231 : SEGDES DSOBJ 232 : C Syntaxe incorrecte : POINT attendu (centre 2D, 2nd point axe 3D) 233 : IF (ITOPE.NE.'POINT ') THEN 234 : MOTERR(1:30) = 'un POINT ' 234 : CALL ERREUR(881) 235 : GOTO 100 236 : ENDIF 237 : SEGACT MCOORD 238 : IREF=IPOIN1*idimp1-IDIM 239 : XPT1=XCOOR(IREF) 240 : YPT1=XCOOR(IREF+1) 241 : IF (IDIM.LT.3) THEN 242 : ZPT1=0. 243 : XVEC=0. 244 : YVEC=0. 245 : ZVEC=1. 246 : ELSE 247 : DSOBJ=nint(PILO(NIOBJ-3)) 248 : SEGACT DSOBJ 249 : ITOPE=LETYP 250 : IPT2=INIPOI 251 : SEGDES DSOBJ 252 : C Syntaxe incorrecte : POIN1 attendu en 3D (1er point axe rotation) 253 : IF (ITOPE.NE.'POINT ') THEN 254 : MOTERR(1:30) = 'deux POINTs ' 254 : CALL ERREUR(881) 255 : GOTO 100 256 : ENDIF 257 : XPT2=XPT1 258 : YPT2=YPT1 259 : ZPT2=XCOOR(IREF+2) 260 : IREF=IPT2*idimp1-IDIM 261 : XPT1=XCOOR(IREF) 262 : YPT1=XCOOR(IREF+1) 263 : ZPT1=XCOOR(IREF+2) 264 : XVEC=XPT2-XPT1 265 : YVEC=YPT2-YPT1 266 : ZVEC=ZPT2-ZPT1 267 : DVEC=SQRT(XVEC*XVEC+YVEC*YVEC+ZVEC*ZVEC) 268 : XVEC=XVEC/DVEC 269 : YVEC=YVEC/DVEC 270 : ZVEC=ZVEC/DVEC 271 : ENDIF 272 : XV1=-YVEC 273 : YV1=XVEC 274 : DV1=XV1*XV1+YV1*YV1 275 : IF (DV1.GE.0.1) THEN 276 : ZV1=0. 277 : DV1=SQRT(DV1) 278 : XV1=XV1/DV1 279 : YV1=YV1/DV1 280 : ELSE 281 : XV1=0. 282 : YV1=-ZVEC 283 : ZV1=YVEC 284 : DV1=SQRT(YV1*YV1+ZV1*ZV1) 285 : YV1=YV1/DV1 286 : ZV1=ZV1/DV1 287 : ENDIF 288 : XV2=YVEC*ZV1-ZVEC*YV1 289 : YV2=ZVEC*XV1-XVEC*ZV1 290 : ZV2=XVEC*YV1-YVEC*XV1 291 : ICPR=ICP1 292 : SEGACT ITABEL*MOD,INOUVEL*MOD 293 : ENDIF 294 : C Operateurs PLUS et MOIN : 295 : C --------------------------- 296 : IF ((ITYP.EQ.1).OR.(ITYP.EQ.2)) THEN 297 : IF ((ITOPE.NE.'MAILLAGE').AND.(ITOPE.NE.'POINT ').AND. 298 : . (ITOPE.NE.'CHPOINT ')) THEN 299 : C Syntaxe incorrecte : le vecteur VEC1, le champ par point CHPO1 ou 300 : C le maillage GEO1 etait attendu 301 : MOTERR(1:30) ='un POINT, CHPOINT ou MAILLAGE' 301 : CALL ERREUR(881) 302 : GOTO 100 303 : ENDIF 304 : C Deplacement (translation) donne par un vecteur VEC1 305 : IF (ITOPE.EQ.'POINT ') THEN 306 : IREF=(IPOIN1-1)*idimp1 307 : SEGACT MCOORD 308 : DO i=1,IDIM 309 : Y(i)=XCOOR(IREF+i)*ISENS 310 : ENDDO 311 : C Deplacement donne par un champ point CHPO1 312 : ELSE IF (ITOPE.EQ.'CHPOINT ') THEN 313 : C Cas particulier : operateur MOINS - maillage GEO1 donne 314 : ELSE IF (ITOPE.EQ.'MAILLAGE') THEN 315 : IPT1=IPOIN1 316 : DSOBJ=nint(PILO(NIOBJ-1)) 317 : SEGACT DSOBJ 318 : IPT2=INIPOI 319 : ITOPE=LETYP 320 : SEGDES DSOBJ 321 : C Syntaxe incorrecte : maillage GEO2 attendu 322 : IF (ITOPE.NE.'MAILLAGE') THEN 323 : MOTERR(1:30) = 'un MAILLAGE ' 323 : CALL ERREUR(881) 324 : GOTO 100 325 : ENDIF 326 : GOTO 500 327 : ENDIF 328 : SEGINI ICPR,INOUVEL,ITABEL 329 : ENDIF 330 : C Operateur TOUR : 331 : C ------------------ 332 : IF (ITYP.EQ.3) THEN 333 : C Syntaxe incorrecte : POINT attendu (centre 2D, 2nd point axe 3D) 334 : IF (ITOPE.NE.'POINT ') THEN 335 : MOTERR(1:30) = 'un POINT ' 335 : CALL ERREUR(881) 336 : GOTO 100 337 : ENDIF 338 : SEGACT MCOORD 339 : IREF=IPOIN1*idimp1-IDIM 340 : XPT1=XCOOR(IREF) 341 : YPT1=XCOOR(IREF+1) 342 : IF (IDIM.LT.3) THEN 343 : ZPT1=0. 344 : XVEC=0. 345 : YVEC=0. 346 : ZVEC=1. 347 : ELSE 348 : DSOBJ=nint(PILO(NIOBJ-1)) 349 : SEGACT DSOBJ 350 : ITOPE=LETYP 351 : IPT2=INIPOI 352 : SEGDES DSOBJ 353 : C Syntaxe incorrecte : POINT attendu en 3D (1er point axe rotation) 354 : IF (ITOPE.NE.'POINT ') THEN 355 : MOTERR(1:30) = 'deux POINTs ' 355 : CALL ERREUR(881) 356 : GOTO 100 357 : ENDIF 358 : XPT2=XPT1 359 : YPT2=YPT1 360 : ZPT2=XCOOR(IREF+2) 361 : IREF=IPT2*idimp1-IDIM 362 : XPT1=XCOOR(IREF) 363 : YPT1=XCOOR(IREF+1) 364 : ZPT1=XCOOR(IREF+2) 365 : XVEC=XPT2-XPT1 366 : YVEC=YPT2-YPT1 367 : ZVEC=ZPT2-ZPT1 368 : DVEC=SQRT(XVEC*XVEC+YVEC*YVEC+ZVEC*ZVEC) 369 : XVEC=XVEC/DVEC 370 : YVEC=YVEC/DVEC 371 : ZVEC=ZVEC/DVEC 372 : ENDIF 373 : XV1=-YVEC 374 : YV1=XVEC 375 : DV1=XV1*XV1+YV1*YV1 376 : IF (DV1.GE.0.1) THEN 377 : ZV1=0. 378 : DV1=SQRT(DV1) 379 : XV1=XV1/DV1 380 : YV1=YV1/DV1 381 : ELSE 382 : XV1=0. 383 : YV1=-ZVEC 384 : ZV1=YVEC 385 : DV1=SQRT(YV1*YV1+ZV1*ZV1) 386 : YV1=YV1/DV1 387 : ZV1=ZV1/DV1 388 : ENDIF 389 : XV2=YVEC*ZV1-ZVEC*YV1 390 : YV2=ZVEC*XV1-XVEC*ZV1 391 : ZV2=XVEC*YV1-YVEC*XV1 392 : SEGINI ICPR,INOUVEL,ITABEL 393 : ENDIF 394 : 395 : C Boucle sur tous les objets a transformer 396 : C ========================================== 397 : DO 200 L=1,NIOBJ-MINIOBJ 398 : DSOBJ=nint(PILO(L)) 399 : SEGACT DSOBJ*MOD 400 : SEGINI IPLMAIL 401 : C IPLMAIL contient tous les maillages elementaires de l'objet L initial 402 : C Creation objet transforme (INIFIN) par copie objet initial (INIPOI) 403 : IF (LETYP.EQ.'MAILLAGE') THEN 404 : IPLMAIL(**)=INIPOI 405 : ELSE IF (LETYP.EQ.'CHPOINT ') THEN 406 : MCHPO1=INIPOI 406 : CALL COPIE2(MCHPO1,MCHPOI) 407 : INIFIN=MCHPOI 408 : SEGACT MCHPOI 409 : DO i=1,IPCHP(/1) 410 : MSOUPO=IPCHP(i) 411 : SEGACT MSOUPO 412 : IPLMAIL(**)=IGEOC 413 : SEGDES MSOUPO 414 : ENDDO 415 : SEGDES MCHPOI 416 : ELSE IF (LETYP.EQ.'MCHAML ') THEN 417 : MCHEL1=INIPOI 417 : CALL COPIE8(MCHEL1,MCHELM) 418 : INIFIN=MCHELM 419 : SEGACT MCHELM 420 : DO i=1,IMACHE(/1) 421 : IPLMAIL(**)=IMACHE(i) 422 : ENDDO 423 : SEGDES MCHELM 424 : ELSE IF (LETYP.EQ.'MMODEL ') THEN 425 : MMODE1=INIPOI 425 : CALL COPIE9(MMODE1,MMODEL) 426 : INIFIN=MMODEL 427 : SEGACT MMODEL 428 : DO i=1,KMODEL(/1) 429 : IMODEL=KMODEL(i) 430 : SEGACT IMODEL 431 : IPLMAIL(**)=IMAMOD 432 : SEGDES IMODEL 433 : ENDDO 434 : SEGDES MMODEL 435 : ELSE IF (LETYP.EQ.'RIGIDITE') THEN 436 : C Syntaxe incorrecte SSI objets RIGIDITE transformes via un CHPOINT 437 : c IPOIN1 qui n'est pas une translation => test dans DEDU3 438 : XERR1 = 0.D0 439 : IF (ITOPE.EQ.'CHPOINT ') THEN 439 : if(ITYP.eq.4) call DEDU3(IPOIN1,XERR1) 440 : if(ITYP.eq.5) XERR1 = 1.D0 441 : ENDIF 442 : IF (XERR1.GT.(1.D-10)) THEN 442 : CALL ERREUR(882) 443 : GOTO 100 444 : ENDIF 445 : RI1=INIPOI 446 : SEGINI,MRIGID=RI1 447 : INIFIN=MRIGID 448 : DO i=1,IRIGEL(/2) 449 : IPLMAIL(**)=IRIGEL(1,i) 450 : ENDDO 451 : SEGDES MRIGID 452 : ELSE IF (LETYP.EQ.'POINT ') THEN 453 : C Cas particulier syntaxe : POIN2 = POIN1 PLUS (MOIN) CHPO1; 454 : C Creation d'un maillage IPT9 contenant un element POI1 455 : IF (ITOPE.EQ.'CHPOINT ') THEN 456 : NBNN=1 457 : NBELEM=1 458 : NBSOUS=0 459 : NBREF=0 460 : SEGINI MELEME 461 : NUM(1,1)=INIPOI 462 : SEGDES MELEME 463 : IPT9=MELEME 464 : IPLMAIL(**)=IPT9 465 : ELSE 466 : C Cas particulier syntaxe : POIN2 = POIN1 PLUS (MOIN) VECT1; 467 : GOTO 210 468 : ENDIF 469 : ENDIF 470 : C Boucle sur les sous-zones de l'objet L a transformer 471 : C Pour ne transformer qu'une seule fois les maillages elementaires, on 472 : C verifie si la zone elementaire est presente dans ITABEL. Si ce n'est 473 : C pas le cas, on doit alors transformer cette zone et on met a jour 474 : C ITABEL et INOUVEL en consequence. 475 : C IPLMAIL contient initialement le maillage a transformer et a la fin 476 : C de la boucle le maillage image (transforme) 477 : DO IMEL=1,IPLMAIL(/1) 478 : MELEME=IPLMAIL(IMEL) 479 : SEGACT MELEME 480 : NBSOUS=LISOUS(/1) 481 : NBREF=LISREF(/1) 482 : C Transformation des sous-objets s'ils existents 483 : IF (NBSOUS.NE.0) THEN 484 : NBNN=0 485 : NBELEM=0 486 : SEGINI IPT1 487 : C Boucle sur les sous-objets 488 : DO J=1,NBSOUS 489 : IF (ITABEL(/1).NE.0) THEN 490 : DO K=1,ITABEL(/1) 491 : C Verification si ce maillage n'a pas deja ete transforme 492 : IF (ITABEL(K).EQ.LISOUS(J)) THEN 493 : IPT1.LISOUS(J)=INOUVEL(K) 494 : GOTO 201 495 : ENDIF 496 : ENDDO 497 : ENDIF 498 : MELE1=LISOUS(J) 499 : C Verification pour DEDU que tous les POINTs de l'objet MELE1 subissent 500 : C la transformation i.e. ont une image, soit ICP(i) non nul 501 : IF ((ITYP.EQ.4).OR.(ITYP.EQ.5)) THEN 501 : CALL DEDU2(MELE1,ICPR,IRETOU,ITYP) 502 : IF (IERR.NE.0) THEN 503 : SEGSUP IPLMAIL 504 : GOTO 300 505 : ENDIF 506 : IF (IRETOU.NE.0) THEN 507 : INTERR(1)=L 507 : CALL ERREUR(883) 508 : SEGSUP IPLMAIL 509 : GOTO 300 510 : ENDIF 511 : ENDIF 512 : ITABEL(**)=LISOUS(J) 513 : C Operateur DEDU : activation obligatoire du segment ICPR 514 : IF ((ITYP.EQ.4).OR.(ITYP.EQ.5)) SEGACT ICPR 515 : C Transformation du maillage MELE1 en NOUV suivant ICLE 516 : IF ((ITOPE.EQ.'POINT ').AND.(ICLE.EQ.1)) THEN 516 : CALL ADDITI(Y,MELE1,NOUV,ICPR) 517 : ELSE IF ((ITOPE.EQ.'CHPOINT ').AND.(ICLE.EQ.1)) THEN 517 : CALL CHDITI(IPOIN1,MELE1,NOUV,ICPR,ISENS) 518 : ELSE IF (ICLE.EQ.2) THEN 518 : CALL ADDITI(Y,MELE1,NOUV,ICPR) 519 : ENDIF 520 : INOUVEL(**)=NOUV 521 : IPT1.LISOUS(J)=NOUV 522 : 201 CONTINUE 523 : ENDDO 524 : C Boucle sur les references si elles existent 525 : IF (NBREF.NE.0) THEN 526 : DO J=1,NBREF 527 : DO K=1,ITABEL(/1) 528 : C Verification si ce maillage n'a pas deja ete transforme 529 : IF (ITABEL(K).EQ.LISREF(J)) THEN 530 : IPT1.LISREF(J)=INOUVEL(K) 531 : GOTO 202 532 : ENDIF 533 : ENDDO 534 : MELE1=LISREF(J) 535 : C Verification pour DEDU que tous les POINTs de l'objet MELE1 subissent 536 : C la transformation i.e. ont une image, soit ICP(i) non nul 537 : IF ((ITYP.EQ.4).OR.(ITYP.EQ.5)) THEN 537 : CALL DEDU2(MELE1,ICPR,IRETOU,ITYP) 538 : IF (IERR.NE.0) THEN 539 : SEGSUP IPLMAIL 540 : GOTO 300 541 : ENDIF 542 : IF (IRETOU.NE.0) THEN 543 : INTERR(1)=L 543 : CALL ERREUR(883) 544 : SEGSUP IPLMAIL 545 : GOTO 300 546 : ENDIF 547 : ENDIF 548 : ITABEL(**)=LISREF(J) 549 : C Operateur DEDU : activation obligatoire du segment ICPR 550 : IF ((ITYP.EQ.4).OR.(ITYP.EQ.5)) SEGACT ICPR 551 : C Transformation du maillage MELE1 en NOUV suivant ICLE 552 : IF ((ITOPE.EQ.'POINT ').AND.(ICLE.EQ.1)) THEN 552 : CALL ADDITI(Y,MELE1,NOUV,ICPR) 553 : ELSE IF ((ITOPE.EQ.'CHPOINT ').AND.(ICLE.EQ.1)) THEN 553 : CALL CHDITI(IPOIN1,MELE1,NOUV,ICPR,ISENS) 554 : ELSE IF (ICLE.EQ.2) THEN 554 : CALL ADDITI(Y,MELE1,NOUV,ICPR) 555 : ENDIF 556 : INOUVEL(**)=NOUV 557 : IPT1.LISREF(J)=NOUV 558 : 202 CONTINUE 559 : ENDDO 560 : ENDIF 561 : SEGDES IPT1 562 : IPLMAIL(IMEL)=IPT1 563 : C L'objet est elementaire 564 : ELSE 565 : IF (ITABEL(/1).NE.0) THEN 566 : C Verification si ce maillage n'a pas deja ete transforme 567 : DO K=1,ITABEL(/1) 568 : IF (ITABEL(K).EQ.MELEME) THEN 569 : IPLMAIL(IMEL)=INOUVEL(K) 570 : GOTO 203 571 : ENDIF 572 : ENDDO 573 : ENDIF 574 : C Verification pour DEDU que tous les POINTs de l'objet MELE1 subissent 575 : C la transformation i.e. ont une image, soit ICP(i) non nul 576 : IF ((ITYP.EQ.4).OR.(ITYP.EQ.5)) THEN 576 : CALL DEDU2(MELEME,ICPR,IRETOU,ITYP) 577 : IF (IERR.NE.0) THEN 578 : SEGSUP IPLMAIL 579 : GOTO 300 580 : ENDIF 581 : IF (IRETOU.NE.0) THEN 582 : INTERR(1)=L 582 : CALL ERREUR(883) 583 : SEGSUP IPLMAIL 584 : GOTO 300 585 : ENDIF 586 : ENDIF 587 : ITABEL(**)=MELEME 588 : C Operateur DEDU : activation obligatoire du segment ICPR 589 : IF ((ITYP.EQ.4).OR.(ITYP.EQ.5)) SEGACT ICPR 590 : C Transformation du maillage MELE1 en NOUV suivant ICLE 591 : IF ((ITOPE.EQ.'POINT ').AND.(ICLE.EQ.1)) THEN 591 : CALL ADDITI(Y,MELEME,NOUV,ICPR) 592 : ELSE IF ((ITOPE.EQ.'CHPOINT ').AND.(ICLE.EQ.1)) THEN 592 : CALL CHDITI(IPOIN1,MELEME,NOUV,ICPR,ISENS) 593 : ELSE IF (ICLE.EQ.2) THEN 593 : CALL ADDITI(Y,MELEME,NOUV,ICPR) 594 : ENDIF 595 : INOUVEL(**)=NOUV 596 : IPLMAIL(IMEL)=NOUV 597 : ENDIF 598 : 203 CONTINUE 599 : SEGDES MELEME 600 : ENDDO 601 : C Fin de la boucle : le maillage support de l'objet L a ete transforme 602 : C Mise a jour de INIFIN (DSOBJ) en consequence avec transformation des 603 : C composantes si l'objet est un CHPOINT ou MCHAML et ICLE=2 (rotation) 604 : 210 IF (LETYP.EQ.'MAILLAGE') THEN 605 : INIFIN=IPLMAIL(1) 606 : ELSE IF (LETYP.EQ.'CHPOINT ') THEN 607 : MCHPOI=INIFIN 608 : SEGACT MCHPOI*MOD 609 : DO i=1,IPCHP(/1) 610 : MSOUPO=IPCHP(i) 611 : SEGACT MSOUPO*MOD 612 : IGEOC=IPLMAIL(i) 613 : SEGDES MSOUPO 614 : ENDDO 615 : SEGDES MCHPOI 615 : IF (ICLE.EQ.2) CALL TOCH1(MCHPOI,'CHPOINT ',IRETOU) 616 : ELSE IF (LETYP.EQ.'MCHAML ') THEN 617 : MCHELM=INIFIN 618 : SEGACT MCHELM*MOD 619 : DO i=1,IMACHE(/1) 620 : IMACHE(i)=IPLMAIL(i) 621 : ENDDO 622 : SEGDES MCHELM 622 : IF (ICLE.EQ.2) CALL TOCH1(MCHELM,'MCHAML ',IRETOU) 623 : ELSE IF (LETYP.EQ.'MMODEL ') THEN 624 : MMODEL=INIFIN 625 : SEGACT MMODEL*MOD 626 : DO i=1,KMODEL(/1) 627 : IMODEL=KMODEL(i) 628 : SEGACT IMODEL*MOD 629 : IMAMOD=IPLMAIL(i) 630 : SEGDES IMODEL 631 : ENDDO 632 : SEGDES MMODEL 633 : ELSE IF (LETYP.EQ.'RIGIDITE') THEN 634 : MRIGID=INIFIN 635 : SEGACT MRIGID*MOD 636 : DO i=1,IRIGEL(/2) 637 : IRIGEL(1,i)=IPLMAIL(i) 638 : ENDDO 639 : SEGDES MRIGID 640 : ELSE IF (LETYP.EQ.'POINT ') THEN 641 : C Cas particulier - Syntaxe : POIN2 = POIN1 'PLUS' VECT1 ; 642 : IF (ITOPE.EQ.'POINT ') THEN 643 : IPOIN1=INIPOI 644 : if(icpr(ipoin1).ne.0) then 645 : inifin=icpr(ipoin1) 646 : else 647 : NBPTS=XCOOR(/1)/idimp1+1 648 : inifin=nbpts 649 : SEGADJ MCOORD 650 : IREF=(IPOIN1-1)*idimp1 651 : IPTFIN=(NBPTS-1)*idimp1 652 : IF ((ICPR(IPOIN1).EQ.0).AND.(ICLE.EQ.1)) THEN 653 : DO i=1,IDIM 654 : XCOOR(IPTFIN+i)=XCOOR(IREF+i)+Y(i) 655 : ENDDO 656 : XCOOR(IPTFIN+idimp1)=DENSIT 657 : ELSE IF ((ICPR(IPOIN1).EQ.0).AND.(ICLE.EQ.2)) THEN 658 : XD=XCOOR(IREF+1)-XPT1 659 : YD=XCOOR(IREF+2)-YPT1 660 : ZD=0. 661 : IF (IDIM.GE.3) ZD=XCOOR(IREF+3)-ZPT1 662 : XE=XD*XV1+YD*YV1+ZD*ZV1 663 : YE=XD*XV2+YD*YV2+ZD*ZV2 664 : ZE=XD*XVEC+YD*YVEC+ZD*ZVEC 665 : XD=XE*CO-YE*SI 666 : YD=XE*SI+YE*CO 667 : ZD=ZE 668 : XCOOR(IPTFIN+1)=XD*XV1+YD*XV2+ZD*XVEC+XPT1 669 : XCOOR(IPTFIN+2)=XD*YV1+YD*YV2+ZD*YVEC+YPT1 670 : IF (IDIM.GE.3) XCOOR(IPTFIN+3)=XD*ZV1+YD*ZV2+ZD*ZVEC+ZPT1 671 : XCOOR(IPTFIN+idimp1)=XCOOR(IREF+idimp1) 672 : C** ELSE IF (ICPR(IPOIN1).NE.0) THEN 673 : ICPR(IPOIN1)=INIFIN 674 : ENDIF 675 : endif 676 : ELSE 677 : C Cas particulier - Syntaxe 2 : POIN2 = POIN1 'PLUS' CHPO1 ; 678 : SEGSUP IPT9 679 : IPT9=IPLMAIL(1) 680 : SEGACT IPT9 681 : INIFIN=IPT9.NUM(1,1) 682 : SEGSUP IPT9 683 : ENDIF 684 : ENDIF 685 : SEGDES DSOBJ 686 : SEGSUP IPLMAIL 687 : 200 CONTINUE 688 : C Fin de la boucle sur les objets DSOBJ a transformer 689 : 690 : C Ecriture dans la pile des objets transformes 691 : * cas particulier si on avait lu une table 692 : if(itab.ne.0) then 693 : mtable=itab 694 : segact mtable*mod 695 : segact iposi 696 : endif 697 : DO i=NIOBJ-MINIOBJ,1,-1 698 : DSOBJ=nint(PILO(i)) 699 : SEGACT DSOBJ 700 : * 701 : IF(LETYP.EQ.'MMODEL ') THEN 702 : MMODEL=INIFIN 703 : SEGACT MMODEL 704 : NSOUS = KMODEL(/1) 705 : * on change les maillages des modeles pointes par un modele MELANGE 706 : * et le pointeur du modele 707 : do im = 1,NSOUS 708 : imodel = kmodel(im) 709 : segact imodel*mod 710 : if (formod(1).eq.'MELANGE') then 711 : if (ivamod(/1).ge.1) then 712 : do ivm1 = 1,ivamod(/1) 713 : if (tymode(ivm1).eq.'IMODEL') then 714 : imode1 = ivamod(ivm1) 715 : segini,imode2=imode1 716 : imode2.imamod = imamod 717 : ivamod(ivm1) = imode2 718 : segdes imode2 719 : endif 720 : enddo 721 : endif 722 : endif 723 : segdes imodel 724 : enddo 725 : SEGDES MMODEL 726 : ENDIF 727 : * 728 : IF(itab.ne.0) then 729 : ipotab=iposit(i) 730 : mtabiv(ipotab)=inifin 731 : ELSE 731 : CALL ECROBJ(LETYP,INIFIN) 732 : ENDIF 733 : SEGDES DSOBJ 734 : ENDDO 735 : if( itab.ne.0) then 735 : call ecrobj('TABLE ',mtable) 736 : segdes mtable 737 : segsup iposi 738 : endif 739 : 740 : C Un peu de menage 741 : 300 SEGSUP ICPR,ITABEL,INOUVEL 742 : GOTO 100 743 : 744 : C Cas particulier - Operateur MOINS : CHPO1 = 'MOIN' GEO1 GEO2 ; 745 : c Calcul du CHPOINT permettant de passer de GEO1 a GEO2 746 : 500 SEGINI ICP1 747 : SEGACT IPT1,IPT2 748 : NBSOUS1=IPT1.LISOUS(/1) 749 : NBSOUS2=IPT2.LISOUS(/1) 750 : *Gounand : Utilité ? NBREF1=IPT1.LISREF(/1) 751 : *G NBREF2=IPT2.LISREF(/1) 752 : IF (NBSOUS1.NE.NBSOUS2) GOTO 502 753 : *G IF (NBREF1.NE.NBREF2) GOTO 502 754 : IF (NBSOUS1.EQ.0) THEN 755 : IF (IPT1.ITYPEL.NE.IPT2.ITYPEL) GOTO 502 756 : IF (IPT1.NUM(/1).NE.IPT2.NUM(/1)) GOTO 502 757 : IF (IPT1.NUM(/2).NE.IPT2.NUM(/2)) GOTO 502 757 : CALL PROCHP(IPT1,IPT2,IPOIN1,ICP1) 758 : IF (IERR.NE.0) GOTO 502 759 : ELSE IF (NBSOUS1.NE.0) THEN 760 : DO j=1,NBSOUS1 761 : IPT3=IPT1.LISOUS(j) 762 : IPT4=IPT2.LISOUS(j) 763 : SEGACT IPT3,IPT4 764 : NBSOUS3=IPT3.LISOUS(/1) 765 : NBSOUS4=IPT4.LISOUS(/1) 766 : *G NBREF3=IPT3.LISREF(/1) 767 : *G NBREF4=IPT4.LISREF(/1) 768 : IF (NBSOUS3.NE.NBSOUS4) GOTO 501 769 : *G IF (NBREF3.NE.NBREF4) GOTO 501 770 : IF (IPT3.ITYPEL.NE.IPT4.ITYPEL) GOTO 501 771 : IF (IPT3.NUM(/1).NE.IPT4.NUM(/1)) GOTO 501 772 : IF (IPT3.NUM(/2).NE.IPT4.NUM(/2)) GOTO 501 773 : SEGDES IPT3,IPT4 773 : CALL PROCHP(IPT3,IPT4,IPOIN1,ICP1) 774 : IF (IERR.NE.0) GOTO 501 775 : IF (j.EQ.1) THEN 776 : IPCHP0=IPOIN1 777 : ELSE 777 : CALL FUCHPO(IPCHP0,IPOIN1,IRET) 778 : IPCHP0=IRET 779 : ENDIF 780 : IF (IERR.NE.0) GOTO 501 781 : ENDDO 782 : IPOIN1=IPCHP0 783 : ENDIF 784 : SEGDES IPT1,IPT2 785 : C Ecriture du CHPOINT calcule 785 : CALL ECROBJ('CHPOINT ',IPOIN1) 786 : C Pour les autres objets DSOBJ, INIFIN=0 donc pas ecrits ? 787 : DO i=NIOBJ-1,2,-1 788 : DSOBJ=nint(PILO(i)) 789 : SEGACT DSOBJ 789 : CALL ECROBJ(LETYP,INIFIN) 790 : SEGDES DSOBJ 791 : ENDDO 792 : GOTO 100 793 : 794 : C Syntaxe particuliere : CHP1 = GEO1 'MOIN' GEO2 ; 795 : C Erreur dans le calcul du CHPOINT, incompatibilite entre les maillages 796 : 501 SEGDES IPT3,IPT4 797 : 502 SEGDES IPT1,IPT2 797 : CALL ERREUR(878) 798 : SEGSUP ICP1 799 : 800 : C Sortie du sousprogramme - Suppression des segments locaux 801 : 100 if(PILO.NE.0) then 802 : DO i=1,PILO(/1) 803 : DSOBJ=nint(PILO(i)) 804 : SEGSUP DSOBJ 805 : ENDDO 806 : SEGSUP PILO 807 : ENDIF 808 : segsup MLITY 809 : RETURN 810 : END 811 : 812 : 813 : 814 : 815 : 816 : 817 : 818 : 819 : 820 : 821 : 822 : 823 : 824 : 825 : 826 : 827 :
© Cast3M 2003 - All rights reserved.
Disclaimer