1 : C EXTREL SOURCE GOUNAND 13/10/21 21:15:18 7844 2 : C 3 : C CE SOUS PROGRAMME A POUR OBJET D'EXTRAIRE D'UN OBJET COMPLEXE 4 : C LE SOUS OBJET FORME DES ELEMENTS DEMANDES 5 : C LA SYNTAXE EN EST : 6 : C ELEM | (TYPE SI PLUSIEURS) | (IEL) 7 : C | (LISTE ENTIERS) 8 : C | CONTENANT POINT (TOUS) 9 : C | APPUYES | (LARGE) OBJ 10 : C | STRICT 11 : C 12 : SUBROUTINE EXTREL(IRR,IFLAG,LIEL) 13 : IMPLICIT INTEGER(I-N) 14 : IMPLICIT REAL*8 (A-H,O-Z) 15 : -INC SMLENTI 16 : -INC SMLMOTS 17 : -INC CCOPTIO 18 : -INC CCGEOME 19 : -INC SMELEME 20 : -INC SMCOORD 21 : -INC CCREEL 22 : SEGMENT ICPR(XCOOR(/1)/(IDIM+1)) 23 : SEGMENT ISOM(NBS) 24 : C 25 : C PP+ CHARACTER*4 MCLE(5),MOTM(9),MOABS(1),MOTAV(2) 26 : PARAMETER (NCLE=6) 27 : CHARACTER*4 MCLE(NCLE),MOTM(9),MOABS(1),MOTAV(2) 28 : CHARACTER*4 MSCLE(3),MCLE2(1) 29 : DIMENSION INBC(10) 30 : DATA MOTAV/'AVEC','SANS'/ 31 : DATA MOTM/'MAXI','MINI','SUPE','EGSU', 32 : . 'EGAL','EGIN','INFE','DIFF','COMP'/ 33 : DATA MOABS/'ABS '/ 34 : C PP+ DATA MCLE/'CONT','APPU','TYPE','COUL','COMP'/ 35 : DATA MCLE/'CONT','APPU','TYPE','COUL','COMP','ZONE'/ 36 : DATA MSCLE/'STRI','LARG','NOVE'/ 37 : DATA MCLE2/'TOUS'/ 38 : C INITIALISATIONS 39 : ICPR=0 40 : IRR=0 41 : ISOM=0 42 : VALREF=0.D0 43 : VALRE2=0.D0 44 : c icle2 relatif a l option TOUS, NIEL= nbre d EF trouves 45 : ICLE2=0 46 : NIEL=0 47 : C 48 : c LECTURE DU MAILLAGE 48 : CALL LIROBJ('MAILLAGE',MELEME,0,IRETOU) 49 : IF(IERR.NE.0) RETURN 50 : IF (IRETOU.NE.0)THEN 51 : * 52 : * EXTRACTION DES ELEMENTS D'UN MAILLAGE 53 : * 54 : SEGACT MELEME 55 : 56 : c LECTURE DES MOTS-CLE 56 : CALL LIRMOT(NOMS,NOMBR,IDES,0) 57 : IF(IDES.NE.0) GOTO 2 57 : CALL LIRMOT (NCOUL,NBCOUL,ICOUL,0) 58 : IF(ICOUL.NE.0) GOTO 11 58 : C PP+ CALL LIRMOT(MCLE,5,IMLU,0) 58 : CALL LIRMOT(MCLE,NCLE,IMLU,0) 59 : IF(IMLU.NE.0) GOTO 20 60 : C ON N'A PAS LU DE MOT-CLE ON PEUT CONTINUER SI L'OBJET CONTIENT UN 61 : C SEUL TYPE D'ELEMENT 61 : IF(LISOUS(/1).NE.0) CALL ERREUR(25) 62 : IF(IERR.NE.0) RETURN 63 : IDES=ITYPEL 64 : 2 CONTINUE 65 : IF(LISOUS(/1).NE.0) GOTO 3 65 : IF(ITYPEL.NE.IDES) CALL ERREUR(26) 66 : IF(IERR.NE.0) RETURN 67 : GOTO 4 68 : 3 CONTINUE 69 : if (ides.ne.22.and.ides.ne.48) then 70 : DO 5 I=1,LISOUS(/1) 71 : IPT2=LISOUS(I) 72 : SEGACT IPT2 73 : IF(IPT2.ITYPEL.EQ.IDES)GOTO 6 74 : SEGDES IPT2 75 : 5 CONTINUE 75 : CALL ERREUR(26) 76 : SEGDES MELEME 77 : RETURN 78 : else 79 : nbso=0 80 : do 555 I=1,LISOUS(/1) 81 : IPT2=LISOUS(I) 82 : SEGACT IPT2 83 : if (IPT2.ITYPEL.EQ.IDES) then 84 : nbso=nbso+1 85 : if (nbso.gt.10) then 85 : call erreur(279) 86 : return 87 : endif 88 : inbc(nbso)=ipt2 89 : segdes ipt2 90 : endif 91 : 555 continue 92 : if (nbso.eq.0) then 92 : call erreur(26) 93 : segdes meleme 94 : return 95 : elseif(nbso.eq.1) then 96 : ipt2=inbc(1) 97 : go to 1000 98 : else 99 : nbnn=0 100 : nbelem=0 101 : nbsous=nbso 102 : nbref=0 103 : segini ipt2 104 : do jo =1,nbso 105 : ipt2.lisous(jo)=inbc(jo) 106 : enddo 107 : go to 1000 108 : endif 109 : endif 110 : 6 SEGDES MELEME 111 : MELEME=IPT2 111 : CALL LIRMOT(NCOUL,NBCOUL,ICOUL,0) 112 : IF(ICOUL.NE.0) GOTO 11 113 : 4 CONTINUE 113 : CALL LIRENT(IEL,0,IRETOU) 114 : IF(IRETOU.EQ.0) GOTO 50 115 : 116 : C ECRITURE DU MAILLAGE RESULTATS 117 : 7 CONTINUE 118 : c write(6,*) 'on arrive en 7'; 119 : SEGACT MELEME 120 : C qq verif 120 : IF(IEL.LE.0.OR.IEL.GT.NUM(/2)) CALL ERREUR(262) 121 : IF(IERR.NE.0) RETURN 122 : C creation (ou ajustement du meleme resultat) 123 : NBSOUS=0 124 : NBREF=0 125 : NBNN=NUM(/1) 126 : IF ((ICLE2.EQ.0).OR.(NIEL.EQ.0)) THEN 127 : NBELEM=1 128 : SEGINI,IPT2 129 : ELSE 130 : C BP: pour l instant on suppose qu on a qu 1 seul type d element 131 : NBELEM=NIEL+1 132 : SEGADJ,IPT2 133 : ENDIF 134 : IPT2.ITYPEL=ITYPEL 135 : IPT2.ICOLOR(NBELEM)=ICOLOR(IEL) 136 : DO 8 I=1,NBNN 137 : IPT2.NUM(I,NBELEM)=NUM(I,IEL) 138 : 8 CONTINUE 139 : NIEL=NBELEM 140 : LIEL=IEL 141 : IF(ISOM.NE.0) SEGDES,ISOM 142 : C OPTION 'TOUS' : ON RECOMMENCE 143 : IF (ICLE2.NE.0) THEN 144 : IOB1=IOB 145 : JDEB1=IEL+1 146 : IF(JDEB1.LE.NUM(/2)) GOTO 25 147 : JDEB1=1 148 : IOB1=IOB1+1 149 : IF(IOB1.LE.MAX(1,LISOUS(/1))) GOTO 25 150 : ENDIF 151 : GOTO 1000 152 : C CAR C'EST FINI 153 : 154 : 11 CONTINUE 155 : ICOUL=ICOUL-1 156 : C DETERMINATION DES ELEMENTS D'UNE COULEUR DONNEE:ICOUL 157 : C REMPLIR LE TABLEAU DU NOMBRE DES ELEMENTS 158 : DO 12 I=1,10 159 : INBC(I)=0 160 : 12 CONTINUE 161 : ICPT=0 162 : IPT1=MELEME 163 : DO 13 I=1,MAX(1,LISOUS(/1)) 164 : IF (LISOUS(/1).NE.0) THEN 165 : IPT1=LISOUS(I) 166 : SEGACT IPT1 167 : ENDIF 168 : ICPT=ICPT+1 169 : DO 15 J=1,IPT1.NUM(/2) 170 : IF(IPT1.ICOLOR(J).EQ.ICOUL) INBC(ICPT)=INBC(ICPT)+1 171 : 15 CONTINUE 172 : IF(LISOUS(/1).NE.0) SEGDES IPT1 173 : 13 CONTINUE 174 : NB=0 175 : DO 17 I=1,10 176 : IF(INBC(I).NE.0) NB=NB+1 177 : 17 CONTINUE 177 : IF(NB.EQ.0) CALL ERREUR(222) 178 : IF (NB.EQ.1) THEN 179 : NBSOUS=0 180 : NBREF=0 181 : IF (LISOUS(/1).NE.0) THEN 182 : DO 18 I=1,10 183 : IF(INBC(I).NE.0) IREP=I 184 : 18 CONTINUE 185 : IPT1=LISOUS(IREP) 186 : SEGACT IPT1 187 : NBNN=IPT1.NUM(/1) 188 : NBELEM=INBC(IREP) 189 : ELSE 190 : NBNN=NUM(/1) 191 : NBELEM=INBC(1) 192 : IPT1=MELEME 193 : ENDIF 194 : SEGINI IPT2 195 : II=0 196 : IPT2.ITYPEL=IPT1.ITYPEL 197 : DO 19 J=1,IPT1.NUM(/2) 198 : IF(IPT1.ICOLOR(J).NE.ICOUL) GOTO 19 199 : II=II+1 200 : IPT2.ICOLOR(II)=ICOUL 201 : DO 93 I=1,NBNN 202 : IPT2.NUM(I,II)=IPT1.NUM(I,J) 203 : 93 CONTINUE 204 : 19 CONTINUE 205 : IF(LISOUS(/1).NE.0) SEGDES IPT1 206 : ELSE 207 : NBSOUS=NB 208 : NBREF=0 209 : NBNN=0 210 : NBELEM=0 211 : SEGINI IPT2 212 : IB=0 213 : DO 90 I=1,10 214 : IF(INBC(I).EQ.0) GOTO 90 215 : IB=IB+1 216 : IPT3=LISOUS(I) 217 : SEGACT IPT3 218 : NBSOUS=0 219 : NBREF=0 220 : NBNN=IPT3.NUM(/1) 221 : NBELEM=INBC(I) 222 : SEGINI IPT4 223 : IPT4.ITYPEL=IPT3.ITYPEL 224 : II=0 225 : DO 91 J=1,IPT3.NUM(/2) 226 : IF(IPT3.ICOLOR(J).NE.ICOUL) GOTO 91 227 : II=II+1 228 : IPT4.ICOLOR(II)=ICOUL 229 : DO 94 K=1,NBNN 230 : IPT4.NUM(K,II)=IPT3.NUM(K,J) 231 : 94 CONTINUE 232 : 91 CONTINUE 233 : SEGDES IPT3 234 : IPT2.LISOUS(IB)=IPT4 235 : SEGDES IPT4 236 : 90 CONTINUE 237 : SEGDES IPT2 238 : ENDIF 239 : SEGDES MELEME 240 : MELEME=IPT2 240 : CALL LIRMOT (NOMS,NOMBR,IDES,0) 241 : IF(IDES.NE.0) GOTO 2 242 : GOTO 4 243 : 244 : 20 CONTINUE 245 : c ON A LU 'CONT', 'APPU', 'TYPE', 'COUL', 'COMP', ou 'ZONE' 246 : IF(IMLU.NE.1) GOTO 30 247 : C ON A LU CONT : ON VEUT LIROBJ UN POINT 247 : CALL LIROBJ('POINT ',IP,1,IRETOU) 248 : IF(IERR.NE.0) RETURN 249 : SEGACT MCOORD 250 : IREFP=(IP-1)*(IDIM+1)+1 251 : XP=XCOOR(IREFP) 252 : YP=XCOOR(IREFP+1) 253 : ZP=XCOOR(IREFP+2) 254 : IF(IDIM.EQ.2) ZP=0.D0 255 : C BP: cherche t on 'TOUS' les elements qui contiennent ce point ? 256 : ICLE2=0 256 : CALL LIRMOT(MCLE2,1,ICLE2,0) 257 : C sg option noverif 258 : NOVER=0 258 : CALL LIRMOT(MSCLE(3),1,NOVER,0) 259 : C NIEL = nbre d'EF trouvés, IOB1 et JDEB1 = debut de boucles 260 : NIEL=0 261 : IOB1=1 262 : JDEB1=1 263 : 25 CONTINUE 264 : IPT1=MELEME 265 : C BOUCLE SUR LES EVENTUELS SOUS-OBJETS 266 : DO 22 IOB=IOB1,MAX(1,LISOUS(/1)) 267 : IF (LISOUS(/1).NE.0) THEN 268 : IPT1=LISOUS(IOB) 269 : SEGACT IPT1 270 : ENDIF 271 : 21 CONTINUE 272 : C 273 : IA1 = 0 274 : IF(IPT1.ITYPEL.EQ.14.OR.IPT1.ITYPEL.EQ.15)IA1 = 1 275 : IF(IPT1.ITYPEL.EQ.16.OR.IPT1.ITYPEL.EQ.17)IA1 = 7 276 : C 277 : NBNN=IPT1.NUM(/1) 278 : IF(KSURF(IPT1.ITYPEL).NE.0) GOTO 60 279 : C C'EST UNE LIGNE 280 : C Recherche du point le plus proche + élément contenant ce point 281 : IPT5 = IPT1 281 : CALL CHANGE(IPT5,1) 282 : IF(IERR.NE.0) RETURN 282 : CALL ECROBJ('POINT ',IP) 282 : CALL ECRCHA('PROC') 282 : CALL ECROBJ('MAILLAGE',IPT5) 282 : CALL POIEXT 282 : CALL LIROBJ('POINT ',IP1,1,IRETOU) 283 : IF(IERR.NE.0) RETURN 284 : SEGACT IPT1 285 : DO 40 J=1,IPT1.NUM(/2) 286 : DO 41 K=1,NBNN 287 : IF (IPT1.NUM(K,J).EQ.IP1) THEN 288 : GOTO 100 289 : ENDIF 290 : 41 CONTINUE 291 : 40 CONTINUE 292 : GOTO 23 293 : 294 : 60 IF(KSURF(IPT1.ITYPEL).NE.IPT1.ITYPEL) GOTO 70 295 : C C'EST UNE SURFACE 296 : NBS = NBSOM(IPT1.ITYPEL) 297 : IF (NBS.EQ.0) THEN 298 : C Polygone a N cotes 299 : NBS = IPT1.NUM(/1) 300 : ENDIF 301 : SEGINI ISOM 302 : DO 61 I=1,ISOM(/1) 303 : ISOM(I)=IBSOM(NSPOS(IPT1.ITYPEL)-1+I) 304 : 61 CONTINUE 305 : DO 62 J=JDEB1,IPT1.NUM(/2) 306 : I1=IPT1.NUM(ISOM(1),J) 307 : I2=IPT1.NUM(ISOM(2),J) 308 : I3=IPT1.NUM(ISOM(3),J) 309 : IREF1=(I1-1)*(IDIM+1) 310 : IREF2=(I2-1)*(IDIM+1) 311 : IREF3=(I3-1)*(IDIM+1) 312 : X1=XCOOR(IREF1+1) 313 : X2=XCOOR(IREF2+1) 314 : X3=XCOOR(IREF3+1) 315 : Y1=XCOOR(IREF1+2) 316 : Y2=XCOOR(IREF2+2) 317 : Y3=XCOOR(IREF3+2) 318 : Z1=XCOOR(IREF1+3) 319 : Z2=XCOOR(IREF2+3) 320 : Z3=XCOOR(IREF3+3) 321 : XNORM=(Y2-Y1)*(Z2-Z3)-(Z2-Z1)*(Y2-Y3) 322 : YNORM=(Z2-Z1)*(X2-X3)-(X2-X1)*(Z2-Z3) 323 : ZNORM=(X2-X1)*(Y2-Y3)-(Y2-Y1)*(X2-X3) 324 : IF (IDIM.EQ.2) THEN 325 : XNORM=0.D0 326 : YNORM=0.D0 327 : ENDIF 328 : DNORM=SQRT(XNORM**2+YNORM**2+ZNORM**2) 329 : XNORM=XNORM/DNORM 330 : YNORM=YNORM/DNORM 331 : ZNORM=ZNORM/DNORM 332 : ANG=0.D0 333 : I1=IPT1.NUM(ISOM(ISOM(/1)),J) 334 : IREF1=(I1-1)*(IDIM+1) 335 : XV1=XCOOR(IREF1+1)-XP 336 : YV1=XCOOR(IREF1+2)-YP 337 : ZV1=XCOOR(IREF1+3)-ZP 338 : IF(IDIM.EQ.2) ZV1=0.D0 339 : DO 63 IS=1,ISOM(/1) 340 : I2=IPT1.NUM(ISOM(IS),J) 341 : IREF2=(I2-1)*(IDIM+1) 342 : XV2=XCOOR(IREF2+1)-XP 343 : YV2=XCOOR(IREF2+2)-YP 344 : ZV2=XCOOR(IREF2+3)-ZP 345 : IF(IDIM.EQ.2) ZV2=0.D0 346 : XATA=XNORM*(YV1*ZV2-ZV1*YV2)+YNORM*(ZV1*XV2-XV1*ZV2)+ 347 : # ZNORM*(XV1*YV2-YV1*XV2) 348 : YATA=XV1*XV2+YV1*YV2+ZV1*ZV2 349 : IF(XATA.EQ.0.D0.AND.YATA.EQ.0.D0) GOTO 100 350 : IF (IFLAG.EQ.1) THEN 351 : IF(ABS(ABS(ATAN2(XATA,YATA))-XPI).LT.0.0001D0)GO 352 : $ TO 100 353 : ENDIF 354 : ANG=ANG+ATAN2(XATA,YATA) 355 : XV1=XV2 356 : YV1=YV2 357 : ZV1=ZV2 358 : 63 CONTINUE 359 : IF (IFLAG.EQ.1) THEN 360 : IF(ABS(ABS(ANG)-XPI).LT.0.0001D0)GO TO 100 361 : ENDIF 362 : IF(ABS(ANG).GT.XPI) GOTO 100 363 : 62 CONTINUE 364 : SEGSUP ISOM 365 : ISOM=0 366 : GOTO 23 367 : 368 : 70 CONTINUE 369 : C C'EST UN VOLUME 370 : NBFAC=LTEL(1,IPT1.ITYPEL) 371 : IAD=LTEL(2,IPT1.ITYPEL)-1 372 : IF(NBFAC.EQ.0) GOTO 23 373 : DO 71 J=JDEB1,IPT1.NUM(/2) 374 : XMI=XGRAND 375 : XMA=-XGRAND 376 : YMI=XGRAND 377 : YMA=-XGRAND 378 : ZMI=XGRAND 379 : ZMA=-XGRAND 380 : DO 710 KKI=1,IPT1.NUM(/1) 381 : IA=(IPT1.NUM(KKI,J)-1)*( IDIM+1) 382 : XMI=MIN(XMI,XCOOR(IA+1)) 383 : XMA=MAX(XMA,XCOOR(IA+1)) 384 : YMI=MIN(YMI,XCOOR(IA+2)) 385 : YMA=MAX(YMA,XCOOR(IA+2)) 386 : ZMI=MIN(ZMI,XCOOR(IA+3)) 387 : ZMA=MAX(ZMA,XCOOR(IA+3)) 388 : 710 CONTINUE 389 : XXM=XMA-XMI 390 : YYM=YMA-YMI 391 : ZZM=ZMA-ZMI 392 : IF( XXM.EQ.0.D0.OR.YYM.EQ.0.D0.OR.ZZM.EQ.0.D0) THEN 392 : CALL ERREUR(26) 393 : RETURN 394 : ENDIF 395 : XDE=((XMI-XP)*(XP-XMA))/XXM/XXM 396 : YDE=((YMI-YP)*(YP-YMA))/YYM/YYM 397 : ZDE=((ZMI-ZP)*(ZP-ZMA))/ZZM/ZZM 398 : IF(XDE.LT.-0.001D0.OR.YDE.LT.-0.001D0.OR.ZDE.LT.-0.001D0 399 : $ )GO TO 71 400 : ANG=0.D0 401 : IMULT = 1 402 : DO 72 IFAC=1,NBFAC 403 : IF(IA1.NE.0) IMULT = KSIF(IA1+IFAC-1) 404 : ITYP=LDEL(1,IAD+IFAC) 405 : NPFAC=KDFAC(1,ITYP) 406 : IF (NPFAC.EQ.0) THEN 407 : C Polygone a n cotes 408 : NPFAC = IPT1.NUM(/1) 409 : ENDIF 410 : JAD=LDEL(2,IAD+IFAC)-1 411 : IA=IPT1.NUM(LFAC(JAD+1),J) 412 : IREFA=(IA-1)*(IDIM+1)+1 413 : DO 73 MAUX=3,NPFAC 414 : IB=IPT1.NUM(LFAC(JAD+MAUX-1),J) 415 : IC=IPT1.NUM(LFAC(JAD+MAUX),J) 416 : IREFB=(IB-1)*(IDIM+1)+1 417 : IREFC=(IC-1)*(IDIM+1)+1 417 : CALL ANGSOL(XCOOR(IREFP),XCOOR(IREFA),XCOOR(IREFB) 418 : $ ,XCOOR(IREFC),AN,IFLAG,IFLIG) 419 : IF (IFLAG.EQ.1) THEN 420 : IF(ABS(ABS(AN)-(2.D0*XPI)).LT.0.0001D0)GO TO 421 : $ 100 422 : IF(IFLIG.EQ.1) GOTO 100 423 : ENDIF 424 : ANG=ANG+AN*IMULT 425 : 73 CONTINUE 426 : 72 CONTINUE 427 : IF(ABS(ANG).GT.XPI) GOTO 100 428 : 71 CONTINUE 429 : 23 CONTINUE 430 : IF(LISOUS(/1).NE.0) SEGDES IPT1 431 : JDEB1=1 432 : 22 CONTINUE 433 : C FIN DE BOUCLE SUR LES SOUS-OBJETS MAILLAGE 434 : c option 'TOUS' + on a trouve au moins 1 element => fin heureuse 435 : IF((ICLE2.NE.0).AND.(NIEL.GE.1)) GOTO 1000 436 : c sinon c est qu on rien trouve => erreur si nover=0 437 : IF (NOVER.EQ.1) THEN 438 : NBSOUS=0 439 : NBREF=0 440 : NBNN=0 441 : NBELEM=0 442 : SEGINI IPT2 443 : GOTO 1000 444 : ENDIF 445 : SEGDES MELEME 446 : IRR=1 447 : RETURN 448 : 449 : 100 IF(LISOUS.NE.0) SEGDES MELEME 450 : MELEME=IPT1 451 : IEL=J 452 : GOTO 7 453 : 454 : 50 CONTINUE 455 : C ON LIT UN OBJET MLENTI 455 : CALL LIROBJ('LISTENTI',MLENTI,0,IRETOU) 456 : IF(IRETOU.EQ.0) GOTO 58 457 : SEGACT MLENTI 458 : NBNN=NUM(/1) 459 : NBELEM=LECT(/1) 460 : NBSOUS=0 461 : NBREF=0 461 : IF(NBELEM.EQ.0) CALL ERREUR(25) 462 : SEGINI IPT2 463 : IPT2.ITYPEL=ITYPEL 464 : DO 51 JJ=1,NBELEM 465 : J=LECT(JJ) 465 : IF(J.LE.0.OR.J.GT.NUM(/2)) CALL ERREUR(36) 466 : IF(IERR.NE.0) GOTO 55 467 : IPT2.ICOLOR(JJ)=ICOLOR(J) 468 : DO 52 I=1,NBNN 469 : IPT2.NUM(I,JJ)=NUM(I,J) 470 : 52 CONTINUE 471 : 51 CONTINUE 472 : SEGDES MLENTI 473 : GOTO 1000 474 : 58 CONTINUE 475 : IPT2=MELEME 476 : GOTO 1001 477 : 55 SEGSUP IPT2 478 : SEGDES MELEME 479 : RETURN 480 : 1000 CONTINUE 481 : SEGDES MELEME 482 : 1001 SEGDES IPT2 482 : CALL ECROBJ('MAILLAGE',IPT2) 483 : RETURN 484 : 30 CONTINUE 485 : IF(IMLU.NE.2) GO TO 330 486 : C ON A LU APPUYE ON LIT UN DEUXIEME OBJET ET ON FAIT EN SORTE QUE 487 : C CE SOIT DES POINTS 488 : C MODIF MAI 1986 ON AUTORISE A LIROBJ UN SEUL POINT 489 : C NOUVELLE OPTION STRICT LARGE 489 : CALL LIRMOT(MSCLE,2,IMSLU,0) 490 : IF(IMSLU.EQ.0) IMSLU=1 490 : CALL LIROBJ('MAILLAGE',IPT1,0,IPLU) 491 : IF (IPLU.EQ.0) THEN 491 : CALL LIROBJ('POINT ',IPT1,1,IRETOU) 492 : IF(IERR.NE.0) RETURN 492 : CALL CRELEM(IPT1) 493 : ELSE 494 : SEGACT IPT1 495 : IPLU=IPT1.ITYPEL 495 : IF(IPLU.NE.1) CALL CHANGE(IPT1,1) 496 : ENDIF 497 : NOVER=0 497 : CALL LIRMOT(MSCLE(3),1,NOVER,0) 498 : SEGINI ICPR 499 : DO 231 I=1,XCOOR(/1)/(IDIM+1) 500 : ICPR(I)=0 501 : 231 CONTINUE 502 : SEGACT IPT1 503 : DO 232 J=1,IPT1.NUM(/2) 504 : ICPR(IPT1.NUM(1,J))=1 505 : 232 CONTINUE 506 : C TEST ET CREATION DU SEGMENT RESULTAT 507 : NBREF=0 508 : NBSOU=LISOUS(/1) 509 : IPT2=MELEME 510 : IF (NBSOU.NE.0) THEN 511 : NBNN=0 512 : NBELEM=0 513 : NBSOUS=NBSOU 514 : SEGINI IPT8 515 : ISO=0 516 : ENDIF 517 : DO 270 ISOUS=1,MAX(1,NBSOU) 518 : IF (NBSOU.NE.0) THEN 519 : IPT2=LISOUS(ISOUS) 520 : SEGACT IPT2 521 : ENDIF 522 : NBNN=IPT2.NUM(/1) 523 : NBELEM=IPT2.NUM(/2) 524 : ICOUNT=0 525 : DO 250 IEL=1,NBELEM 526 : IF (IMSLU.EQ.1) THEN 527 : DO 251 INOEU=1,NBNN 528 : IF(ICPR(IPT2.NUM(INOEU,IEL)).EQ.0) GOTO 250 529 : 251 CONTINUE 530 : ICOUNT=ICOUNT+1 531 : ELSE 532 : DO 252 INOEU=1,NBNN 533 : IF(ICPR(IPT2.NUM(INOEU,IEL)).NE.0) GOTO 253 534 : 252 CONTINUE 535 : GOTO 250 536 : 253 CONTINUE 537 : ICOUNT=ICOUNT+1 538 : ENDIF 539 : 250 CONTINUE 540 : NBSOUS=0 541 : NBREF=0 542 : NBEL=NBELEM 543 : NBELEM=ICOUNT 544 : ICOUNT=1 545 : IF(NBELEM.EQ.0) GOTO 260 546 : SEGINI IPT3 547 : IPT3.ITYPEL=IPT2.ITYPEL 548 : DO 255 IEL=1,NBEL 549 : IF (IMSLU.EQ.1) THEN 550 : DO 256 INOEU=1,NBNN 551 : IF(ICPR(IPT2.NUM(INOEU,IEL)).EQ.0) GOTO 255 552 : IPT3.NUM(INOEU,ICOUNT)=IPT2.NUM(INOEU,IEL) 553 : 256 CONTINUE 554 : IPT3.ICOLOR(ICOUNT)=IPT2.ICOLOR(IEL) 555 : ICOUNT=ICOUNT+1 556 : IF(ICOUNT.GT.NBELEM) GOTO 260 557 : ELSE 558 : IOOK=0 559 : DO 257 INOEU=1,NBNN 560 : IF(ICPR(IPT2.NUM(INOEU,IEL)).NE.0) IOOK=1 561 : IPT3.NUM(INOEU,ICOUNT)=IPT2.NUM(INOEU,IEL) 562 : 257 CONTINUE 563 : IF(IOOK.EQ.0) GOTO 255 564 : IPT3.ICOLOR(ICOUNT)=IPT2.ICOLOR(IEL) 565 : ICOUNT=ICOUNT+1 566 : IF(ICOUNT.GT.NBELEM) GOTO 260 567 : ENDIF 568 : 255 CONTINUE 569 : 260 CONTINUE 570 : IF (NBSOU.EQ.0) THEN 571 : IF (NBELEM.EQ.0) THEN 572 : IF (NOVER.EQ.0) THEN 573 : GOTO 9988 574 : ELSE 575 : NBSOUS=0 576 : NBREF=0 577 : NBNN=0 578 : NBELEM=0 579 : SEGINI IPT4 579 : CALL ECROBJ('MAILLAGE',IPT4) 580 : RETURN 581 : ENDIF 582 : ENDIF 583 : GOTO 280 584 : ENDIF 585 : IF (NBELEM.NE.0) THEN 586 : IPT8.LISOUS(ISOUS)=IPT3 587 : ISO=ISO+1 588 : SEGDES IPT3 589 : ENDIF 590 : 270 CONTINUE 591 : IF (ISO.EQ.1) THEN 592 : SEGSUP IPT8 593 : GOTO 280 594 : ENDIF 595 : IPT3=IPT8 596 : IF(ISO.EQ.NBSOU) GOTO 280 597 : NBSOUS=ISO 598 : NBREF=0 599 : NBNN=0 600 : NBELEM=0 601 : SEGINI IPT4 602 : ISO=0 603 : DO 275 IS=1,NBSOU 604 : IF(IPT3.LISOUS(IS).EQ.0) GOTO 275 605 : ISO=ISO+1 606 : IPT4.LISOUS(ISO)=IPT3.LISOUS(IS) 607 : 275 CONTINUE 608 : IF (ISO.EQ.0) THEN 609 : IF (NOVER.EQ.0) THEN 610 : GOTO 9988 611 : ELSE 612 : NBSOUS=0 613 : NBREF=0 614 : NBNN=0 615 : NBELEM=0 616 : SEGINI IPT4 616 : CALL ECROBJ('MAILLAGE',IPT4) 617 : RETURN 618 : ENDIF 619 : ENDIF 620 : SEGSUP IPT3 621 : IPT3=IPT4 622 : 280 CONTINUE 623 : SEGDES IPT3 623 : CALL ECROBJ('MAILLAGE',IPT3) 624 : SEGDES IPT1 625 : SEGSUP ICPR 626 : RETURN 627 : 330 CONTINUE 628 : IF(IMLU.NE.3) GO TO 340 629 : * 630 : * OPTION 'TYPE' SELON PROPOSITION ISPRA 631 : * 632 : I1=LISOUS(/1) 633 : JGN=4 634 : JGM=MAX(1,I1) 635 : SEGINI MLMOTS 636 : IF (I1.EQ.0) THEN 637 : MOTS(1)=NOMS(ITYPEL) 638 : ELSE 639 : DO 33 I=1,I1 640 : IPT2=LISOUS(I) 641 : SEGACT IPT2 642 : IDES=IPT2.ITYPEL 643 : MOTS(I)=NOMS(IDES) 644 : SEGDES IPT2 645 : 33 CONTINUE 646 : ENDIF 647 : SEGDES MLMOTS 648 : SEGDES,MELEME 648 : CALL ECROBJ('LISTMOTS',MLMOTS) 649 : RETURN 650 : * 651 : 340 CONTINUE 652 : IF(IMLU.NE.4) GO TO 350 653 : C PPc JG=NBCOUL 654 : JG=NBCOUL+1 655 : SEGINI,MLENTI 656 : C PPc DO IE1=1,NBCOUL 657 : DO IE1=1,NBCOUL+1 658 : LECT(IE1)=0 659 : ENDDO 660 : I1=LISOUS(/1) 661 : DO IE1=1,MAX(I1,1) 662 : IF (I1.EQ.0)THEN 663 : IPT2=MELEME 664 : ELSE 665 : IPT2=LISOUS(IE1) 666 : SEGACT,IPT2 667 : ENDIF 668 : DO IE2=1,ICOLOR(/1) 669 : C PPc LECT(ICOLOR(IE2))=1 670 : LECT(ICOLOR(IE2)+1)=1 671 : ENDDO 672 : SEGDES,IPT2 673 : ENDDO 674 : SEGDES,MELEME 675 : JGN=4 676 : JGM=0 677 : DO IE1=1,NBCOUL 678 : JGM=JGM+LECT(IE1) 679 : ENDDO 680 : SEGINI MLMOTS 681 : JGM=0 682 : C+PPc 683 : IF (LECT(1).NE.0)THEN 684 : JGM=JGM+1 685 : MOTS(JGM)='DEFA' 686 : ENDIF 687 : C+PPc 688 : C PPc DO IE1=1,NBCOUL 689 : DO IE1=2,NBCOUL+1 690 : IF (LECT(IE1).NE.0)THEN 691 : JGM=JGM+1 692 : C PPc MOTS(JGM)=NCOUL(IE1) 693 : MOTS(JGM)=NCOUL(IE1-1) 694 : ENDIF 695 : ENDDO 696 : SEGSUP,MLENTI 697 : SEGDES,MLMOTS 697 : CALL ECROBJ('LISTMOTS',MLMOTS) 698 : RETURN 699 : * 700 : 350 CONTINUE 701 : C+PP+ 702 : IF(IMLU.NE.5) GO TO 360 703 : C+PP+ 704 : * option segment 'COMPRIS' entre 2 points d une ligne 705 : * on recycle l operateur COMPRIS 01/2000 kich 705 : CALL ECROBJ('MAILLAGE',MELEME) 705 : CALL COMPRI 706 : RETURN 707 : C+PP+ 708 : * 709 : * OPTION ZONE 710 : * 711 : 360 CONTINUE 712 : SEGACT,MELEME 713 : NBSOUS=LISOUS(/1) 713 : CALL LIRENT(IZONE,0,IRETOU) 714 : IF (IRETOU.NE.0)THEN 715 : * 716 : * EXTRACTION D'UNE ZONE 717 : * 718 : IF (NBSOUS.EQ.0.AND.IZONE.EQ.1)THEN 718 : CALL ECROBJ('MAILLAGE',MELEME) 719 : ELSEIF(IZONE.LE.NBSOUS)THEN 719 : CALL ECROBJ('MAILLAGE',LISOUS(IZONE)) 720 : ELSE 720 : CALL ERREUR(279) 721 : ENDIF 722 : ELSE 723 : * 724 : * NB DE ZONE 725 : * 726 : IF(NBSOUS.EQ.0)NBSOUS=NBSOUS+1 726 : CALL ECRENT(NBSOUS) 727 : ENDIF 728 : SEGDES,MELEME 729 : RETURN 730 : C+PP 731 : * 732 : 9988 CONTINUE 733 : if (icpr.ne.0) then 734 : * write (6,*) ' extrel destruction de icpr' 735 : segsup icpr 736 : endif 737 : IRR=1 738 : RETURN 739 : ELSE 740 : * 741 : * EXTRACTION DES ELEMENTS D'UN CHAMP/ELEMENT 742 : * 743 : IPLIS=0 743 : CALL LIROBJ('MCHAML',IPCHE,1,IRET) 744 : IF(IERR.NE.0)RETURN 744 : CALL LIRMOT(MOTM,9,IMM,1) 745 : IF(IERR.NE.0)RETURN 746 : IF (IMM.GT.2) THEN 746 : CALL LIRREE(VALREF,1,IRET) 747 : IF(IERR.NE.0)RETURN 748 : IF (IMM.EQ.9) THEN 748 : CALL LIRREE(VALRE2,1,IRET) 749 : IF(IERR.NE.0)RETURN 750 : ENDIF 751 : ENDIF 751 : CALL LIRMOT(MOABS,1,IAB,0) 751 : CALL LIRMOT(MOTAV,2,IAV,0) 752 : IF(IAV.EQ.0)IAV=1 752 : CALL LIROBJ('LISTMOTS',IPLIS,0,IRET) 753 : IF(IERR.NE.0)RETURN 753 : CALL EXELCH(IPCHE,IMM,IAB,IAV,IPLIS,VALREF,VALRE2,IPMAIL) 753 : IF(IERR.EQ.0)CALL ECROBJ('MAILLAGE',IPMAIL) 754 : RETURN 755 : ENDIF 756 : * 757 : END 758 : 759 : 760 : 761 : 762 : 763 : 764 : 765 : 766 : 767 : 768 : 769 : 770 : 771 : 772 : 773 : 774 : 775 : 776 : 777 : 778 : 779 : 780 :
© Cast3M 2003 - All rights reserved.
Disclaimer