1 : C ELIMIN SOURCE PV 12/12/06 21:15:07 7594 2 : C 3 : SUBROUTINE ELIMIN(ICPR,CRIT,ITE,IAPOB1,IAPOB2,MELEME,MELEM2,ICLE) 4 : IMPLICIT INTEGER(I-N) 5 : IMPLICIT REAL*8 (A-H,O-Z) 6 : C====================================================================== 7 : C FUSION DES NOEUDS AYANT DES COORDONNEES TROP VOISINES 8 : C UTILISE PAR L'OPERATEUR ELIM ICLE=0 ET PAR L'OPERATEUR VISA ICLE=1 9 : C APPEL PRELIMINAIRE DE PRELIM QUI CREE LES TABLEAUX 10 : C 11 : C ICPR EST LA MOUVELLE NUMEROTATION 12 : C ICPR(ANCIEN N°)= NOUVEAU N° 13 : C ICPR(ANCIEN N°)= 0 SI LE NOEUDS N'APPARTIENT PAS AU MAILLAGE(S 14 : C ) ARGUMENT(S) 15 : C IAPOB1 EST UN TABLEAU SUR LA NOUVELLE NUMEROTATION 16 : C =1 SI LE NOEUD EST DANS LE 1ER MAILLGE =0 SINON 17 : C =2 SI LE NOEUD SUPPORTE UN MULTIPLICATEUR 18 : C IAPOB2 EST UN TABLEAU SUR LA NOUVELLE NUMEROTATION 19 : C =1 SI LE NOEUD EST DANS LE 2IEME MAILLGE =0 SINON 20 : C====================================================================== 21 : -INC CCOPTIO 22 : -INC SMCOORD 23 : 24 : -INC SMLENTI 25 : -INC SMELEME 26 : POINTEUR MELEM2.MELEME 27 : SEGMENT /STRAV/(NP1(ITF),NP2(ITF),NP3(ITF),NPI(ITF),IDCP(ITF)) 28 : SEGMENT ICPR(1) 29 : SEGMENT IAPOB1(1) 30 : SEGMENT IAPOB2(1) 31 : SEGMENT ITLAC(0) 32 : INTEGER TRUC,TRUC1,TRUC3 33 : G(A,B,C,D,E,F)=((A-D)*(A-D)+(B-E)*(B-E)+(C-F)*(C-F)) 34 : C====================================================================== 35 : SEGACT MCOORD*MOD 36 : IF (ITE.LE.1) RETURN 37 : ITF=ITE+3+1 38 : SEGINI STRAV 39 : * IDCP = tableau reciproque de ICPR 40 : DO 250 I=1,ICPR(/1) 41 : IF (ICPR(I).NE.0) IDCP(ICPR(I))=I 42 : 250 CONTINUE 43 : NUMNP=ITE 44 : PREC=CRIT 45 : PREC2=PREC*PREC 46 : NCO2=0 47 : DO 5 I=1,NUMNP 48 : NPI(I)=I 49 : 5 CONTINUE 50 : C 51 : C APPEL DE TRISUP QUI CREE LES TABLEAUX CONTENUS DANS STRAV 51 : CALL TRISUP(NUMNP,PREC,NG,TRUC,TRUC1,CRIT,XMIN,YMIN,ZMIN,STRAV) 52 : IF (IIMPI.NE.0) WRITE (IOIMP,74) NUMNP,NG,TRUC,TRUC1 53 : 74 FORMAT (1X,'NUMNP=',I5,2X,'NG=',I5,2X,'TRUC=',I8,2X,'TRUC1=',I8) 54 : KELI=0 55 : TRUC3=TRUC*TRUC1 56 : ID=NUMNP 57 : IA=1 58 : IB=ITE-1 59 : CRUT=1.D0/CRIT 60 : IF(ICLE.EQ.1) THEN 61 : JG=20 62 : SEGINI MLENTI,MLENT1 63 : ENDIF 64 : C 65 : XI2=0.D0 66 : XI3=0.D0 67 : C BOUCLE SUR LES POINTS DU(DES) MAILLAGE(S) 68 : DO 6 I=IA,IB 69 : IREF=IDCP(I)*(IDIM+1)-IDIM 70 : XI1=XCOOR(IREF) 71 : NX1=INT((XI1-PREC-XMIN)*CRUT+2.D0) 72 : NX2=INT((XI1+PREC-XMIN)*CRUT+2.D0) 73 : IF (IDIM.GE.2) THEN 74 : XI2=XCOOR(IREF+1) 75 : NY1=INT((XI2-PREC-YMIN)*CRUT+1.D0)*TRUC 76 : NY2=INT((XI2+PREC-YMIN)*CRUT+1.D0)*TRUC 77 : ELSE 78 : C* XI2=0 79 : NY1=INT(1.D0-PREC*CRUT)*TRUC 80 : NY2=INT(1.D0+PREC*CRUT)*TRUC 81 : ENDIF 82 : IF (IDIM.GE.3) THEN 83 : XI3=XCOOR(IREF+2) 84 : NZ1=INT((XI3-PREC-ZMIN)*CRUT+1.D0)*TRUC3 85 : NZ2=INT((XI3+PREC-ZMIN)*CRUT+1.D0)*TRUC3 86 : ELSE 87 : C* XI3=0 88 : NZ1=INT(1.D0-PREC*CRUT)*TRUC3 89 : NZ2=INT(1.D0+PREC*CRUT)*TRUC3 90 : ENDIF 91 : IC=I+1 92 : C 93 : C BOUCLE SUR LES ZONES CREE PAR TRISUP 94 : XJ2=0.D0 95 : XJ3=0.D0 96 : DO 7 II=NZ1,NZ2,TRUC3 97 : DO 71 JJ=NY1,NY2,TRUC 98 : NTEST1=II+JJ+NX1 99 : NTEST3=II+JJ+NX2 100 : NZON1=NTEST1/NG+1 101 : NZON3=NTEST3/NG+1 102 : ND=NP1(NZON1)+1 103 : NF=NP1(NZON3+1) 104 : IF(ND.GT.NF) GO TO 71 105 : DO 72 M=ND,NF 106 : IF(NP3(M).LT.NTEST1) GO TO 72 107 : IF(NP3(M).GT.NTEST3) GO TO 71 108 : J=NP2(M) 109 : IF(J.GT.ID.OR.J.LT.IC) GO TO 72 110 : IREF=IDCP(J)*(IDIM+1)-IDIM 111 : XJ1=XCOOR(IREF) 112 : IF (IDIM.GE.2) XJ2=XCOOR(IREF+1) 113 : IF (IDIM.GE.3) XJ3=XCOOR(IREF+2) 114 : A=G(XI1,XI2,XI3,XJ1,XJ2,XJ3) 115 : NCO2=NCO2+1 116 : IF (A.GT.PREC2) GO TO 72 117 : IF (NPI(J).LT.0.AND.ICLE.EQ.0) GOTO 72 118 : IF ((IAPOB1(I) .EQ. 2) .OR. (IAPOB1(J) .EQ. 2)) GOTO 119 : $ 72 120 : IF (((IAPOB1(I).EQ.0).AND.(IAPOB1(J).EQ.0)).OR. 121 : # ((IAPOB2(I).EQ.0).AND.(IAPOB2(J).EQ.0))) GOTO 122 : $ 72 123 : IF (IAPOB1(I).NE.0) THEN 124 : IREF1=(IDCP(I)-1)*(IDIM+1) 125 : IREF2=(IDCP(J)-1)*(IDIM+1) 126 : ELSE 127 : IREF1=(IDCP(J)-1)*(IDIM+1) 128 : IREF2=(IDCP(I)-1)*(IDIM+1) 129 : ENDIF 130 : NPI(J)=-I 131 : KELI=KELI+1 132 : C 133 : IF(ICLE.EQ.0) THEN 134 : * ON SOUDE LE PREMIER POINT SUR LE SECOND 135 : DO 10 III=1,IDIM+1 136 : XCOOR(IREF1+III)=XCOOR(IREF2+III) 137 : 10 CONTINUE 138 : C 139 : ELSEIF(ICLE.EQ.1) THEN 140 : IF(KELI.GT.JG) THEN 141 : JG=JG+20 142 : SEGADJ MLENTI,MLENT1 143 : ENDIF 144 : LECT(KELI)=IDCP(I) 145 : MLENT1.LECT(KELI)=IDCP(J) 146 : ENDIF 147 : C 148 : 72 CONTINUE 149 : 71 CONTINUE 150 : 7 CONTINUE 151 : 6 CONTINUE 152 : C 153 : IJ=0 154 : ICONT=0 155 : DO 101 I=1,NUMNP 156 : 102 IF(NPI(I).GT.0) GOTO 101 157 : IJ=-NPI(I) 158 : NPI(I)=NPI(IJ) 159 : ICONT=ICONT+1 160 : GOTO 102 161 : 101 CONTINUE 162 : C 163 : IF(ICLE.EQ.0) THEN 164 : INTERR(1) = ICONT 165 : C Erreur -293 : Nombre de noeuds eliminés %i1 165 : CALL ERREUR(-293) 166 : DO 103 I=1,XCOOR(/1)/(IDIM+1) 167 : IPC=ICPR(I) 168 : IF (IPC.EQ.0)GOTO 103 169 : ICPR(I)=NPI(IPC) 170 : 103 CONTINUE 171 : SEGSUP STRAV 172 : NUMNP=0 173 : DO 104 I=1,XCOOR(/1)/(IDIM+1) 174 : NUMNP=MAX(NUMNP,ICPR(I)) 175 : 104 CONTINUE 176 : SEGINI ITLAC 176 : IF (MELEME.NE.0) CALL AJOU(ITLAC,MELEME) 176 : IF (MELEM2.NE.0) CALL AJOU(ITLAC,MELEM2) 177 : C il reste a renumeroter les coordonnes(tasser la pile des points) 178 : C et a changer les references dans tous les objets qui pointent 179 : C sur des noeuds 179 : CALL TASSP2(ITLAC,ICPR,NUMNP,ICOLAC,0) 180 : C TASSP2 nous a cree un ICOLAC dont on n'a que faire. 181 : C l'appel suivant supprime ICOLAC et ses sous-objets (donc ITLAC) 181 : CALL SUPPIL(ICOLAC,-1) 182 : C 183 : ELSEIF(ICLE.EQ.1) THEN 184 : SEGSUP STRAV 185 : IF(KELI.NE.0) THEN 186 : NBELEM=KELI 187 : NBNN=1 188 : NBREF=0 189 : NBSOUS=0 190 : SEGINI IPT3,IPT2 191 : IPT2.ITYPEL=1 192 : IPT3.ITYPEL=1 193 : DO 105 I=1,KELI 194 : IPT2.NUM(1,I)=LECT(I) 195 : IPT3.NUM(1,I)=MLENT1.LECT(I) 196 : 105 CONTINUE 197 : SEGDES IPT3,IPT2 198 : SEGSUP MLENTI,MLENT1 198 : CALL ECROBJ('MAILLAGE',IPT3) 198 : CALL ECROBJ('MAILLAGE',IPT2) 199 : C Erreur 22 : Opération malvenue. Résultat douteux 199 : IF(ICONT.NE.KELI) CALL ERREUR(22) 200 : ELSE 201 : C Erreur 26 : Tache impossible. Probablement données erronées 201 : CALL ERREUR(26) 202 : ENDIF 203 : ENDIF 204 : RETURN 205 : END 206 : 207 : 208 : 209 :
© Cast3M 2003 - All rights reserved.
Disclaimer