C ELIMIN SOURCE PV 22/01/11 21:15:20 11258 C SUBROUTINE ELIMIN(ICPR,CRIT,ITE,IAPOB1,IAPOB2,MELEME,MELEM2,ICLE) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) C====================================================================== C FUSION DES NOEUDS AYANT DES COORDONNEES TROP VOISINES C UTILISE PAR L'OPERATEUR ELIM ICLE=0 ET PAR L'OPERATEUR VISA ICLE=1 C APPEL PRELIMINAIRE DE PRELIM QUI CREE LES TABLEAUX C C ICPR EST LA MOUVELLE NUMEROTATION C ICPR(ANCIEN N°)= NOUVEAU N° C ICPR(ANCIEN N°)= 0 SI LE NOEUDS N'APPARTIENT PAS AU MAILLAGE(S C ) ARGUMENT(S) C IAPOB1 EST UN TABLEAU SUR LA NOUVELLE NUMEROTATION C =1 SI LE NOEUD EST DANS LE 1ER MAILLGE =0 SINON C =2 SI LE NOEUD SUPPORTE UN MULTIPLICATEUR C IAPOB2 EST UN TABLEAU SUR LA NOUVELLE NUMEROTATION C =1 SI LE NOEUD EST DANS LE 2IEME MAILLGE =0 SINON C====================================================================== -INC PPARAM -INC CCOPTIO -INC SMCOORD -INC SMLENTI -INC SMELEME POINTEUR MELEM2.MELEME SEGMENT /STRAV/(NP1(ITF),NP2(ITF),NP3(ITF),NPI(ITF),IDCP(ITF), & NP4(ITF),NP5(ITF)) SEGMENT ICPR(1) SEGMENT IAPOB1(1) SEGMENT IAPOB2(1) SEGMENT ITLAC(0) INTEGER TRUC,TRUC1,TRUC3 G(A,B,C,D,E,F)=((A-D)*(A-D)+(B-E)*(B-E)+(C-F)*(C-F)) C====================================================================== SEGACT MCOORD*MOD IF (ITE.LE.1) RETURN ITF=ITE+3+1 SEGINI STRAV * IDCP = tableau reciproque de ICPR DO 250 I=1,ICPR(/1) IF (ICPR(I).NE.0) IDCP(ICPR(I))=I 250 CONTINUE NUMNP=ITE PREC=CRIT PREC2=PREC*PREC NCO2=0 DO 5 I=1,NUMNP NPI(I)=I 5 CONTINUE C C APPEL DE TRISUP QUI CREE LES TABLEAUX CONTENUS DANS STRAV CALL TRISUP(NUMNP,PREC,NG,TRUC,TRUC1,CRIT,XMIN,YMIN,ZMIN,STRAV) IF (IIMPI.NE.0) WRITE (IOIMP,74) NUMNP,NG,TRUC,TRUC1 74 FORMAT (1X,'NUMNP=',I5,2X,'NG=',I5,2X,'TRUC=',I8,2X,'TRUC1=',I8) KELI=0 TRUC3=TRUC*TRUC1 ID=NUMNP IA=1 IB=ITE-1 CRUT=1.D0/CRIT IF(ICLE.EQ.1) THEN JG=20 SEGINI MLENTI,MLENT1 ENDIF C XI2=0.D0 XI3=0.D0 C BOUCLE SUR LES POINTS DU(DES) MAILLAGE(S) DO 6 I=IA,IB IREF=IDCP(I)*(IDIM+1)-IDIM XI1=XCOOR(IREF) NX1=INT((XI1-PREC-XMIN)*CRUT+2.D0) NX2=INT((XI1+PREC-XMIN)*CRUT+2.D0) IF (IDIM.GE.2) THEN XI2=XCOOR(IREF+1) NY1=INT((XI2-PREC-YMIN)*CRUT+1.D0)*TRUC NY2=INT((XI2+PREC-YMIN)*CRUT+1.D0)*TRUC ELSE C* XI2=0 NY1=INT(1.D0-PREC*CRUT)*TRUC NY2=INT(1.D0+PREC*CRUT)*TRUC ENDIF IF (IDIM.GE.3) THEN XI3=XCOOR(IREF+2) NZ1=INT((XI3-PREC-ZMIN)*CRUT+1.D0)*TRUC3 NZ2=INT((XI3+PREC-ZMIN)*CRUT+1.D0)*TRUC3 ELSE C* XI3=0 NZ1=INT(1.D0-PREC*CRUT)*TRUC3 NZ2=INT(1.D0+PREC*CRUT)*TRUC3 ENDIF IC=I+1 C C BOUCLE SUR LES ZONES CREE PAR TRISUP XJ2=0.D0 XJ3=0.D0 DO 7 II=NZ1,NZ2,TRUC3 DO 71 JJ=NY1,NY2,TRUC NTEST1=II+JJ+NX1 NTEST3=II+JJ+NX2 NZON1=NTEST1/NG+1 NZON3=NTEST3/NG+1 ND=NP1(NZON1)+1 NF=NP1(NZON3+1) IF(ND.GT.NF) GO TO 71 DO 72 M=ND,NF IF(NP3(M).LT.NTEST1) GO TO 72 IF(NP3(M).GT.NTEST3) GO TO 71 J=NP2(M) IF(J.GT.ID.OR.J.LT.IC) GO TO 72 IREF=IDCP(J)*(IDIM+1)-IDIM XJ1=XCOOR(IREF) IF (IDIM.GE.2) XJ2=XCOOR(IREF+1) IF (IDIM.GE.3) XJ3=XCOOR(IREF+2) A=G(XI1,XI2,XI3,XJ1,XJ2,XJ3) NCO2=NCO2+1 IF (A.GT.PREC2) GO TO 72 IF (NPI(J).LT.0.AND.ICLE.LE.0) GOTO 72 IF ((IAPOB1(I) .EQ. 2) .OR. (IAPOB1(J) .EQ. 2)) GOTO $ 72 IF (((IAPOB1(I).EQ.0).AND.(IAPOB1(J).EQ.0)).OR. # ((IAPOB2(I).EQ.0).AND.(IAPOB2(J).EQ.0))) GOTO $ 72 IF (IAPOB1(I).NE.0) THEN IREF1=(IDCP(I)-1)*(IDIM+1) IREF2=(IDCP(J)-1)*(IDIM+1) ELSE IREF1=(IDCP(J)-1)*(IDIM+1) IREF2=(IDCP(I)-1)*(IDIM+1) ENDIF NPI(J)=-I KELI=KELI+1 C IF(ICLE.LE.0) THEN * ON SOUDE LE PREMIER POINT SUR LE SECOND DO 10 III=1,IDIM+1 XCOOR(IREF1+III)=XCOOR(IREF2+III) 10 CONTINUE C ELSEIF(ICLE.EQ.1) THEN IF(KELI.GT.JG) THEN JG=JG+20 SEGADJ MLENTI,MLENT1 ENDIF LECT(KELI)=IDCP(I) MLENT1.LECT(KELI)=IDCP(J) ENDIF C 72 CONTINUE 71 CONTINUE 7 CONTINUE 6 CONTINUE C IJ=0 ICONT=0 DO 101 I=1,NUMNP 102 IF(NPI(I).GT.0) GOTO 101 IJ=-NPI(I) NPI(I)=NPI(IJ) ICONT=ICONT+1 GOTO 102 101 CONTINUE C IF(ICLE.LE.0) THEN INTERR(1) = ICONT C Erreur -293 : Nombre de noeuds eliminés %i1 CALL ERREUR(-293) DO 103 I=1,nbpts IPC=ICPR(I) IF (IPC.EQ.0)GOTO 103 ICPR(I)=NPI(IPC) 103 CONTINUE SEGSUP STRAV NUMNP=0 DO 104 I=1,nbpts NUMNP=MAX(NUMNP,ICPR(I)) 104 CONTINUE SEGINI ITLAC IF (MELEME.NE.0) CALL AJOU(ITLAC,MELEME) IF (MELEM2.NE.0) CALL AJOU(ITLAC,MELEM2) C il reste a renumeroter les coordonnes(tasser la pile des points) C et a changer les references dans tous les objets qui pointent C sur des noeuds IDONN=0 IF(ICLE.EQ.-1) IDONN=1 CALL TASSP2(ITLAC,ICPR,NUMNP,ICOLAC,0,IDONN) C TASSP2 nous a cree un ICOLAC dont on n'a que faire. C l'appel suivant supprime ICOLAC et ses sous-objets (donc ITLAC) CALL SUPPIL(ICOLAC,-1) C ELSEIF(ICLE.EQ.1) THEN SEGSUP STRAV IF(KELI.NE.0) THEN NBELEM=KELI NBNN=1 NBREF=0 NBSOUS=0 SEGINI IPT3,IPT2 IPT2.ITYPEL=1 IPT3.ITYPEL=1 DO 105 I=1,KELI IPT2.NUM(1,I)=LECT(I) IPT3.NUM(1,I)=MLENT1.LECT(I) 105 CONTINUE SEGDES IPT3,IPT2 SEGSUP MLENTI,MLENT1 CALL ECROBJ('MAILLAGE',IPT3) CALL ECROBJ('MAILLAGE',IPT2) C Erreur 22 : Opération malvenue. Résultat douteux IF(ICONT.NE.KELI) CALL ERREUR(22) ELSE C Erreur 26 : Tache impossible. Probablement données erronées CALL ERREUR(26) ENDIF ENDIF RETURN END