C EXTREL SOURCE GOUNAND 13/10/21 21:15:18 7844 C C CE SOUS PROGRAMME A POUR OBJET D'EXTRAIRE D'UN OBJET COMPLEXE C LE SOUS OBJET FORME DES ELEMENTS DEMANDES C LA SYNTAXE EN EST : C ELEM | (TYPE SI PLUSIEURS) | (IEL) C | (LISTE ENTIERS) C | CONTENANT POINT (TOUS) C | APPUYES | (LARGE) OBJ C | STRICT C SUBROUTINE EXTREL(IRR,IFLAG,LIEL) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) -INC SMLENTI -INC SMLMOTS -INC CCOPTIO -INC CCGEOME -INC SMELEME -INC SMCOORD -INC CCREEL SEGMENT ICPR(XCOOR(/1)/(IDIM+1)) SEGMENT ISOM(NBS) C C PP+ CHARACTER*4 MCLE(5),MOTM(9),MOABS(1),MOTAV(2) PARAMETER (NCLE=6) CHARACTER*4 MCLE(NCLE),MOTM(9),MOABS(1),MOTAV(2) CHARACTER*4 MSCLE(3),MCLE2(1) DIMENSION INBC(10) DATA MOTAV/'AVEC','SANS'/ DATA MOTM/'MAXI','MINI','SUPE','EGSU', . 'EGAL','EGIN','INFE','DIFF','COMP'/ DATA MOABS/'ABS '/ C PP+ DATA MCLE/'CONT','APPU','TYPE','COUL','COMP'/ DATA MCLE/'CONT','APPU','TYPE','COUL','COMP','ZONE'/ DATA MSCLE/'STRI','LARG','NOVE'/ DATA MCLE2/'TOUS'/ C INITIALISATIONS ICPR=0 IRR=0 ISOM=0 VALREF=0.D0 VALRE2=0.D0 c icle2 relatif a l option TOUS, NIEL= nbre d EF trouves ICLE2=0 NIEL=0 C c LECTURE DU MAILLAGE CALL LIROBJ('MAILLAGE',MELEME,0,IRETOU) IF(IERR.NE.0) RETURN IF (IRETOU.NE.0)THEN * * EXTRACTION DES ELEMENTS D'UN MAILLAGE * SEGACT MELEME c LECTURE DES MOTS-CLE CALL LIRMOT(NOMS,NOMBR,IDES,0) IF(IDES.NE.0) GOTO 2 CALL LIRMOT (NCOUL,NBCOUL,ICOUL,0) IF(ICOUL.NE.0) GOTO 11 C PP+ CALL LIRMOT(MCLE,5,IMLU,0) CALL LIRMOT(MCLE,NCLE,IMLU,0) IF(IMLU.NE.0) GOTO 20 C ON N'A PAS LU DE MOT-CLE ON PEUT CONTINUER SI L'OBJET CONTIENT UN C SEUL TYPE D'ELEMENT IF(LISOUS(/1).NE.0) CALL ERREUR(25) IF(IERR.NE.0) RETURN IDES=ITYPEL 2 CONTINUE IF(LISOUS(/1).NE.0) GOTO 3 IF(ITYPEL.NE.IDES) CALL ERREUR(26) IF(IERR.NE.0) RETURN GOTO 4 3 CONTINUE if (ides.ne.22.and.ides.ne.48) then DO 5 I=1,LISOUS(/1) IPT2=LISOUS(I) SEGACT IPT2 IF(IPT2.ITYPEL.EQ.IDES)GOTO 6 SEGDES IPT2 5 CONTINUE CALL ERREUR(26) SEGDES MELEME RETURN else nbso=0 do 555 I=1,LISOUS(/1) IPT2=LISOUS(I) SEGACT IPT2 if (IPT2.ITYPEL.EQ.IDES) then nbso=nbso+1 if (nbso.gt.10) then call erreur(279) return endif inbc(nbso)=ipt2 segdes ipt2 endif 555 continue if (nbso.eq.0) then call erreur(26) segdes meleme return elseif(nbso.eq.1) then ipt2=inbc(1) go to 1000 else nbnn=0 nbelem=0 nbsous=nbso nbref=0 segini ipt2 do jo =1,nbso ipt2.lisous(jo)=inbc(jo) enddo go to 1000 endif endif 6 SEGDES MELEME MELEME=IPT2 CALL LIRMOT(NCOUL,NBCOUL,ICOUL,0) IF(ICOUL.NE.0) GOTO 11 4 CONTINUE CALL LIRENT(IEL,0,IRETOU) IF(IRETOU.EQ.0) GOTO 50 C ECRITURE DU MAILLAGE RESULTATS 7 CONTINUE c write(6,*) 'on arrive en 7'; SEGACT MELEME C qq verif IF(IEL.LE.0.OR.IEL.GT.NUM(/2)) CALL ERREUR(262) IF(IERR.NE.0) RETURN C creation (ou ajustement du meleme resultat) NBSOUS=0 NBREF=0 NBNN=NUM(/1) IF ((ICLE2.EQ.0).OR.(NIEL.EQ.0)) THEN NBELEM=1 SEGINI,IPT2 ELSE C BP: pour l instant on suppose qu on a qu 1 seul type d element NBELEM=NIEL+1 SEGADJ,IPT2 ENDIF IPT2.ITYPEL=ITYPEL IPT2.ICOLOR(NBELEM)=ICOLOR(IEL) DO 8 I=1,NBNN IPT2.NUM(I,NBELEM)=NUM(I,IEL) 8 CONTINUE NIEL=NBELEM LIEL=IEL IF(ISOM.NE.0) SEGDES,ISOM C OPTION 'TOUS' : ON RECOMMENCE IF (ICLE2.NE.0) THEN IOB1=IOB JDEB1=IEL+1 IF(JDEB1.LE.NUM(/2)) GOTO 25 JDEB1=1 IOB1=IOB1+1 IF(IOB1.LE.MAX(1,LISOUS(/1))) GOTO 25 ENDIF GOTO 1000 C CAR C'EST FINI 11 CONTINUE ICOUL=ICOUL-1 C DETERMINATION DES ELEMENTS D'UNE COULEUR DONNEE:ICOUL C REMPLIR LE TABLEAU DU NOMBRE DES ELEMENTS DO 12 I=1,10 INBC(I)=0 12 CONTINUE ICPT=0 IPT1=MELEME DO 13 I=1,MAX(1,LISOUS(/1)) IF (LISOUS(/1).NE.0) THEN IPT1=LISOUS(I) SEGACT IPT1 ENDIF ICPT=ICPT+1 DO 15 J=1,IPT1.NUM(/2) IF(IPT1.ICOLOR(J).EQ.ICOUL) INBC(ICPT)=INBC(ICPT)+1 15 CONTINUE IF(LISOUS(/1).NE.0) SEGDES IPT1 13 CONTINUE NB=0 DO 17 I=1,10 IF(INBC(I).NE.0) NB=NB+1 17 CONTINUE IF(NB.EQ.0) CALL ERREUR(222) IF (NB.EQ.1) THEN NBSOUS=0 NBREF=0 IF (LISOUS(/1).NE.0) THEN DO 18 I=1,10 IF(INBC(I).NE.0) IREP=I 18 CONTINUE IPT1=LISOUS(IREP) SEGACT IPT1 NBNN=IPT1.NUM(/1) NBELEM=INBC(IREP) ELSE NBNN=NUM(/1) NBELEM=INBC(1) IPT1=MELEME ENDIF SEGINI IPT2 II=0 IPT2.ITYPEL=IPT1.ITYPEL DO 19 J=1,IPT1.NUM(/2) IF(IPT1.ICOLOR(J).NE.ICOUL) GOTO 19 II=II+1 IPT2.ICOLOR(II)=ICOUL DO 93 I=1,NBNN IPT2.NUM(I,II)=IPT1.NUM(I,J) 93 CONTINUE 19 CONTINUE IF(LISOUS(/1).NE.0) SEGDES IPT1 ELSE NBSOUS=NB NBREF=0 NBNN=0 NBELEM=0 SEGINI IPT2 IB=0 DO 90 I=1,10 IF(INBC(I).EQ.0) GOTO 90 IB=IB+1 IPT3=LISOUS(I) SEGACT IPT3 NBSOUS=0 NBREF=0 NBNN=IPT3.NUM(/1) NBELEM=INBC(I) SEGINI IPT4 IPT4.ITYPEL=IPT3.ITYPEL II=0 DO 91 J=1,IPT3.NUM(/2) IF(IPT3.ICOLOR(J).NE.ICOUL) GOTO 91 II=II+1 IPT4.ICOLOR(II)=ICOUL DO 94 K=1,NBNN IPT4.NUM(K,II)=IPT3.NUM(K,J) 94 CONTINUE 91 CONTINUE SEGDES IPT3 IPT2.LISOUS(IB)=IPT4 SEGDES IPT4 90 CONTINUE SEGDES IPT2 ENDIF SEGDES MELEME MELEME=IPT2 CALL LIRMOT (NOMS,NOMBR,IDES,0) IF(IDES.NE.0) GOTO 2 GOTO 4 20 CONTINUE c ON A LU 'CONT', 'APPU', 'TYPE', 'COUL', 'COMP', ou 'ZONE' IF(IMLU.NE.1) GOTO 30 C ON A LU CONT : ON VEUT LIROBJ UN POINT CALL LIROBJ('POINT ',IP,1,IRETOU) IF(IERR.NE.0) RETURN SEGACT MCOORD IREFP=(IP-1)*(IDIM+1)+1 XP=XCOOR(IREFP) YP=XCOOR(IREFP+1) ZP=XCOOR(IREFP+2) IF(IDIM.EQ.2) ZP=0.D0 C BP: cherche t on 'TOUS' les elements qui contiennent ce point ? ICLE2=0 CALL LIRMOT(MCLE2,1,ICLE2,0) C sg option noverif NOVER=0 CALL LIRMOT(MSCLE(3),1,NOVER,0) C NIEL = nbre d'EF trouvés, IOB1 et JDEB1 = debut de boucles NIEL=0 IOB1=1 JDEB1=1 25 CONTINUE IPT1=MELEME C BOUCLE SUR LES EVENTUELS SOUS-OBJETS DO 22 IOB=IOB1,MAX(1,LISOUS(/1)) IF (LISOUS(/1).NE.0) THEN IPT1=LISOUS(IOB) SEGACT IPT1 ENDIF 21 CONTINUE C IA1 = 0 IF(IPT1.ITYPEL.EQ.14.OR.IPT1.ITYPEL.EQ.15)IA1 = 1 IF(IPT1.ITYPEL.EQ.16.OR.IPT1.ITYPEL.EQ.17)IA1 = 7 C NBNN=IPT1.NUM(/1) IF(KSURF(IPT1.ITYPEL).NE.0) GOTO 60 C C'EST UNE LIGNE C Recherche du point le plus proche + élément contenant ce point IPT5 = IPT1 CALL CHANGE(IPT5,1) IF(IERR.NE.0) RETURN CALL ECROBJ('POINT ',IP) CALL ECRCHA('PROC') CALL ECROBJ('MAILLAGE',IPT5) CALL POIEXT CALL LIROBJ('POINT ',IP1,1,IRETOU) IF(IERR.NE.0) RETURN SEGACT IPT1 DO 40 J=1,IPT1.NUM(/2) DO 41 K=1,NBNN IF (IPT1.NUM(K,J).EQ.IP1) THEN GOTO 100 ENDIF 41 CONTINUE 40 CONTINUE GOTO 23 60 IF(KSURF(IPT1.ITYPEL).NE.IPT1.ITYPEL) GOTO 70 C C'EST UNE SURFACE NBS = NBSOM(IPT1.ITYPEL) IF (NBS.EQ.0) THEN C Polygone a N cotes NBS = IPT1.NUM(/1) ENDIF SEGINI ISOM DO 61 I=1,ISOM(/1) ISOM(I)=IBSOM(NSPOS(IPT1.ITYPEL)-1+I) 61 CONTINUE DO 62 J=JDEB1,IPT1.NUM(/2) I1=IPT1.NUM(ISOM(1),J) I2=IPT1.NUM(ISOM(2),J) I3=IPT1.NUM(ISOM(3),J) IREF1=(I1-1)*(IDIM+1) IREF2=(I2-1)*(IDIM+1) IREF3=(I3-1)*(IDIM+1) X1=XCOOR(IREF1+1) X2=XCOOR(IREF2+1) X3=XCOOR(IREF3+1) Y1=XCOOR(IREF1+2) Y2=XCOOR(IREF2+2) Y3=XCOOR(IREF3+2) Z1=XCOOR(IREF1+3) Z2=XCOOR(IREF2+3) Z3=XCOOR(IREF3+3) XNORM=(Y2-Y1)*(Z2-Z3)-(Z2-Z1)*(Y2-Y3) YNORM=(Z2-Z1)*(X2-X3)-(X2-X1)*(Z2-Z3) ZNORM=(X2-X1)*(Y2-Y3)-(Y2-Y1)*(X2-X3) IF (IDIM.EQ.2) THEN XNORM=0.D0 YNORM=0.D0 ENDIF DNORM=SQRT(XNORM**2+YNORM**2+ZNORM**2) XNORM=XNORM/DNORM YNORM=YNORM/DNORM ZNORM=ZNORM/DNORM ANG=0.D0 I1=IPT1.NUM(ISOM(ISOM(/1)),J) IREF1=(I1-1)*(IDIM+1) XV1=XCOOR(IREF1+1)-XP YV1=XCOOR(IREF1+2)-YP ZV1=XCOOR(IREF1+3)-ZP IF(IDIM.EQ.2) ZV1=0.D0 DO 63 IS=1,ISOM(/1) I2=IPT1.NUM(ISOM(IS),J) IREF2=(I2-1)*(IDIM+1) XV2=XCOOR(IREF2+1)-XP YV2=XCOOR(IREF2+2)-YP ZV2=XCOOR(IREF2+3)-ZP IF(IDIM.EQ.2) ZV2=0.D0 XATA=XNORM*(YV1*ZV2-ZV1*YV2)+YNORM*(ZV1*XV2-XV1*ZV2)+ # ZNORM*(XV1*YV2-YV1*XV2) YATA=XV1*XV2+YV1*YV2+ZV1*ZV2 IF(XATA.EQ.0.D0.AND.YATA.EQ.0.D0) GOTO 100 IF (IFLAG.EQ.1) THEN IF(ABS(ABS(ATAN2(XATA,YATA))-XPI).LT.0.0001D0)GO $ TO 100 ENDIF ANG=ANG+ATAN2(XATA,YATA) XV1=XV2 YV1=YV2 ZV1=ZV2 63 CONTINUE IF (IFLAG.EQ.1) THEN IF(ABS(ABS(ANG)-XPI).LT.0.0001D0)GO TO 100 ENDIF IF(ABS(ANG).GT.XPI) GOTO 100 62 CONTINUE SEGSUP ISOM ISOM=0 GOTO 23 70 CONTINUE C C'EST UN VOLUME NBFAC=LTEL(1,IPT1.ITYPEL) IAD=LTEL(2,IPT1.ITYPEL)-1 IF(NBFAC.EQ.0) GOTO 23 DO 71 J=JDEB1,IPT1.NUM(/2) XMI=XGRAND XMA=-XGRAND YMI=XGRAND YMA=-XGRAND ZMI=XGRAND ZMA=-XGRAND DO 710 KKI=1,IPT1.NUM(/1) IA=(IPT1.NUM(KKI,J)-1)*( IDIM+1) XMI=MIN(XMI,XCOOR(IA+1)) XMA=MAX(XMA,XCOOR(IA+1)) YMI=MIN(YMI,XCOOR(IA+2)) YMA=MAX(YMA,XCOOR(IA+2)) ZMI=MIN(ZMI,XCOOR(IA+3)) ZMA=MAX(ZMA,XCOOR(IA+3)) 710 CONTINUE XXM=XMA-XMI YYM=YMA-YMI ZZM=ZMA-ZMI IF( XXM.EQ.0.D0.OR.YYM.EQ.0.D0.OR.ZZM.EQ.0.D0) THEN CALL ERREUR(26) RETURN ENDIF XDE=((XMI-XP)*(XP-XMA))/XXM/XXM YDE=((YMI-YP)*(YP-YMA))/YYM/YYM ZDE=((ZMI-ZP)*(ZP-ZMA))/ZZM/ZZM IF(XDE.LT.-0.001D0.OR.YDE.LT.-0.001D0.OR.ZDE.LT.-0.001D0 $ )GO TO 71 ANG=0.D0 IMULT = 1 DO 72 IFAC=1,NBFAC IF(IA1.NE.0) IMULT = KSIF(IA1+IFAC-1) ITYP=LDEL(1,IAD+IFAC) NPFAC=KDFAC(1,ITYP) IF (NPFAC.EQ.0) THEN C Polygone a n cotes NPFAC = IPT1.NUM(/1) ENDIF JAD=LDEL(2,IAD+IFAC)-1 IA=IPT1.NUM(LFAC(JAD+1),J) IREFA=(IA-1)*(IDIM+1)+1 DO 73 MAUX=3,NPFAC IB=IPT1.NUM(LFAC(JAD+MAUX-1),J) IC=IPT1.NUM(LFAC(JAD+MAUX),J) IREFB=(IB-1)*(IDIM+1)+1 IREFC=(IC-1)*(IDIM+1)+1 CALL ANGSOL(XCOOR(IREFP),XCOOR(IREFA),XCOOR(IREFB) $ ,XCOOR(IREFC),AN,IFLAG,IFLIG) IF (IFLAG.EQ.1) THEN IF(ABS(ABS(AN)-(2.D0*XPI)).LT.0.0001D0)GO TO $ 100 IF(IFLIG.EQ.1) GOTO 100 ENDIF ANG=ANG+AN*IMULT 73 CONTINUE 72 CONTINUE IF(ABS(ANG).GT.XPI) GOTO 100 71 CONTINUE 23 CONTINUE IF(LISOUS(/1).NE.0) SEGDES IPT1 JDEB1=1 22 CONTINUE C FIN DE BOUCLE SUR LES SOUS-OBJETS MAILLAGE c option 'TOUS' + on a trouve au moins 1 element => fin heureuse IF((ICLE2.NE.0).AND.(NIEL.GE.1)) GOTO 1000 c sinon c est qu on rien trouve => erreur si nover=0 IF (NOVER.EQ.1) THEN NBSOUS=0 NBREF=0 NBNN=0 NBELEM=0 SEGINI IPT2 GOTO 1000 ENDIF SEGDES MELEME IRR=1 RETURN 100 IF(LISOUS.NE.0) SEGDES MELEME MELEME=IPT1 IEL=J GOTO 7 50 CONTINUE C ON LIT UN OBJET MLENTI CALL LIROBJ('LISTENTI',MLENTI,0,IRETOU) IF(IRETOU.EQ.0) GOTO 58 SEGACT MLENTI NBNN=NUM(/1) NBELEM=LECT(/1) NBSOUS=0 NBREF=0 IF(NBELEM.EQ.0) CALL ERREUR(25) SEGINI IPT2 IPT2.ITYPEL=ITYPEL DO 51 JJ=1,NBELEM J=LECT(JJ) IF(J.LE.0.OR.J.GT.NUM(/2)) CALL ERREUR(36) IF(IERR.NE.0) GOTO 55 IPT2.ICOLOR(JJ)=ICOLOR(J) DO 52 I=1,NBNN IPT2.NUM(I,JJ)=NUM(I,J) 52 CONTINUE 51 CONTINUE SEGDES MLENTI GOTO 1000 58 CONTINUE IPT2=MELEME GOTO 1001 55 SEGSUP IPT2 SEGDES MELEME RETURN 1000 CONTINUE SEGDES MELEME 1001 SEGDES IPT2 CALL ECROBJ('MAILLAGE',IPT2) RETURN 30 CONTINUE IF(IMLU.NE.2) GO TO 330 C ON A LU APPUYE ON LIT UN DEUXIEME OBJET ET ON FAIT EN SORTE QUE C CE SOIT DES POINTS C MODIF MAI 1986 ON AUTORISE A LIROBJ UN SEUL POINT C NOUVELLE OPTION STRICT LARGE CALL LIRMOT(MSCLE,2,IMSLU,0) IF(IMSLU.EQ.0) IMSLU=1 CALL LIROBJ('MAILLAGE',IPT1,0,IPLU) IF (IPLU.EQ.0) THEN CALL LIROBJ('POINT ',IPT1,1,IRETOU) IF(IERR.NE.0) RETURN CALL CRELEM(IPT1) ELSE SEGACT IPT1 IPLU=IPT1.ITYPEL IF(IPLU.NE.1) CALL CHANGE(IPT1,1) ENDIF NOVER=0 CALL LIRMOT(MSCLE(3),1,NOVER,0) SEGINI ICPR DO 231 I=1,XCOOR(/1)/(IDIM+1) ICPR(I)=0 231 CONTINUE SEGACT IPT1 DO 232 J=1,IPT1.NUM(/2) ICPR(IPT1.NUM(1,J))=1 232 CONTINUE C TEST ET CREATION DU SEGMENT RESULTAT NBREF=0 NBSOU=LISOUS(/1) IPT2=MELEME IF (NBSOU.NE.0) THEN NBNN=0 NBELEM=0 NBSOUS=NBSOU SEGINI IPT8 ISO=0 ENDIF DO 270 ISOUS=1,MAX(1,NBSOU) IF (NBSOU.NE.0) THEN IPT2=LISOUS(ISOUS) SEGACT IPT2 ENDIF NBNN=IPT2.NUM(/1) NBELEM=IPT2.NUM(/2) ICOUNT=0 DO 250 IEL=1,NBELEM IF (IMSLU.EQ.1) THEN DO 251 INOEU=1,NBNN IF(ICPR(IPT2.NUM(INOEU,IEL)).EQ.0) GOTO 250 251 CONTINUE ICOUNT=ICOUNT+1 ELSE DO 252 INOEU=1,NBNN IF(ICPR(IPT2.NUM(INOEU,IEL)).NE.0) GOTO 253 252 CONTINUE GOTO 250 253 CONTINUE ICOUNT=ICOUNT+1 ENDIF 250 CONTINUE NBSOUS=0 NBREF=0 NBEL=NBELEM NBELEM=ICOUNT ICOUNT=1 IF(NBELEM.EQ.0) GOTO 260 SEGINI IPT3 IPT3.ITYPEL=IPT2.ITYPEL DO 255 IEL=1,NBEL IF (IMSLU.EQ.1) THEN DO 256 INOEU=1,NBNN IF(ICPR(IPT2.NUM(INOEU,IEL)).EQ.0) GOTO 255 IPT3.NUM(INOEU,ICOUNT)=IPT2.NUM(INOEU,IEL) 256 CONTINUE IPT3.ICOLOR(ICOUNT)=IPT2.ICOLOR(IEL) ICOUNT=ICOUNT+1 IF(ICOUNT.GT.NBELEM) GOTO 260 ELSE IOOK=0 DO 257 INOEU=1,NBNN IF(ICPR(IPT2.NUM(INOEU,IEL)).NE.0) IOOK=1 IPT3.NUM(INOEU,ICOUNT)=IPT2.NUM(INOEU,IEL) 257 CONTINUE IF(IOOK.EQ.0) GOTO 255 IPT3.ICOLOR(ICOUNT)=IPT2.ICOLOR(IEL) ICOUNT=ICOUNT+1 IF(ICOUNT.GT.NBELEM) GOTO 260 ENDIF 255 CONTINUE 260 CONTINUE IF (NBSOU.EQ.0) THEN IF (NBELEM.EQ.0) THEN IF (NOVER.EQ.0) THEN GOTO 9988 ELSE NBSOUS=0 NBREF=0 NBNN=0 NBELEM=0 SEGINI IPT4 CALL ECROBJ('MAILLAGE',IPT4) RETURN ENDIF ENDIF GOTO 280 ENDIF IF (NBELEM.NE.0) THEN IPT8.LISOUS(ISOUS)=IPT3 ISO=ISO+1 SEGDES IPT3 ENDIF 270 CONTINUE IF (ISO.EQ.1) THEN SEGSUP IPT8 GOTO 280 ENDIF IPT3=IPT8 IF(ISO.EQ.NBSOU) GOTO 280 NBSOUS=ISO NBREF=0 NBNN=0 NBELEM=0 SEGINI IPT4 ISO=0 DO 275 IS=1,NBSOU IF(IPT3.LISOUS(IS).EQ.0) GOTO 275 ISO=ISO+1 IPT4.LISOUS(ISO)=IPT3.LISOUS(IS) 275 CONTINUE IF (ISO.EQ.0) THEN IF (NOVER.EQ.0) THEN GOTO 9988 ELSE NBSOUS=0 NBREF=0 NBNN=0 NBELEM=0 SEGINI IPT4 CALL ECROBJ('MAILLAGE',IPT4) RETURN ENDIF ENDIF SEGSUP IPT3 IPT3=IPT4 280 CONTINUE SEGDES IPT3 CALL ECROBJ('MAILLAGE',IPT3) SEGDES IPT1 SEGSUP ICPR RETURN 330 CONTINUE IF(IMLU.NE.3) GO TO 340 * * OPTION 'TYPE' SELON PROPOSITION ISPRA * I1=LISOUS(/1) JGN=4 JGM=MAX(1,I1) SEGINI MLMOTS IF (I1.EQ.0) THEN MOTS(1)=NOMS(ITYPEL) ELSE DO 33 I=1,I1 IPT2=LISOUS(I) SEGACT IPT2 IDES=IPT2.ITYPEL MOTS(I)=NOMS(IDES) SEGDES IPT2 33 CONTINUE ENDIF SEGDES MLMOTS SEGDES,MELEME CALL ECROBJ('LISTMOTS',MLMOTS) RETURN * 340 CONTINUE IF(IMLU.NE.4) GO TO 350 C PPc JG=NBCOUL JG=NBCOUL+1 SEGINI,MLENTI C PPc DO IE1=1,NBCOUL DO IE1=1,NBCOUL+1 LECT(IE1)=0 ENDDO I1=LISOUS(/1) DO IE1=1,MAX(I1,1) IF (I1.EQ.0)THEN IPT2=MELEME ELSE IPT2=LISOUS(IE1) SEGACT,IPT2 ENDIF DO IE2=1,ICOLOR(/1) C PPc LECT(ICOLOR(IE2))=1 LECT(ICOLOR(IE2)+1)=1 ENDDO SEGDES,IPT2 ENDDO SEGDES,MELEME JGN=4 JGM=0 DO IE1=1,NBCOUL JGM=JGM+LECT(IE1) ENDDO SEGINI MLMOTS JGM=0 C+PPc IF (LECT(1).NE.0)THEN JGM=JGM+1 MOTS(JGM)='DEFA' ENDIF C+PPc C PPc DO IE1=1,NBCOUL DO IE1=2,NBCOUL+1 IF (LECT(IE1).NE.0)THEN JGM=JGM+1 C PPc MOTS(JGM)=NCOUL(IE1) MOTS(JGM)=NCOUL(IE1-1) ENDIF ENDDO SEGSUP,MLENTI SEGDES,MLMOTS CALL ECROBJ('LISTMOTS',MLMOTS) RETURN * 350 CONTINUE C+PP+ IF(IMLU.NE.5) GO TO 360 C+PP+ * option segment 'COMPRIS' entre 2 points d une ligne * on recycle l operateur COMPRIS 01/2000 kich CALL ECROBJ('MAILLAGE',MELEME) CALL COMPRI RETURN C+PP+ * * OPTION ZONE * 360 CONTINUE SEGACT,MELEME NBSOUS=LISOUS(/1) CALL LIRENT(IZONE,0,IRETOU) IF (IRETOU.NE.0)THEN * * EXTRACTION D'UNE ZONE * IF (NBSOUS.EQ.0.AND.IZONE.EQ.1)THEN CALL ECROBJ('MAILLAGE',MELEME) ELSEIF(IZONE.LE.NBSOUS)THEN CALL ECROBJ('MAILLAGE',LISOUS(IZONE)) ELSE CALL ERREUR(279) ENDIF ELSE * * NB DE ZONE * IF(NBSOUS.EQ.0)NBSOUS=NBSOUS+1 CALL ECRENT(NBSOUS) ENDIF SEGDES,MELEME RETURN C+PP * 9988 CONTINUE if (icpr.ne.0) then * write (6,*) ' extrel destruction de icpr' segsup icpr endif IRR=1 RETURN ELSE * * EXTRACTION DES ELEMENTS D'UN CHAMP/ELEMENT * IPLIS=0 CALL LIROBJ('MCHAML',IPCHE,1,IRET) IF(IERR.NE.0)RETURN CALL LIRMOT(MOTM,9,IMM,1) IF(IERR.NE.0)RETURN IF (IMM.GT.2) THEN CALL LIRREE(VALREF,1,IRET) IF(IERR.NE.0)RETURN IF (IMM.EQ.9) THEN CALL LIRREE(VALRE2,1,IRET) IF(IERR.NE.0)RETURN ENDIF ENDIF CALL LIRMOT(MOABS,1,IAB,0) CALL LIRMOT(MOTAV,2,IAV,0) IF(IAV.EQ.0)IAV=1 CALL LIROBJ('LISTMOTS',IPLIS,0,IRET) IF(IERR.NE.0)RETURN CALL EXELCH(IPCHE,IMM,IAB,IAV,IPLIS,VALREF,VALRE2,IPMAIL) IF(IERR.EQ.0)CALL ECROBJ('MAILLAGE',IPMAIL) RETURN ENDIF * END