1 : C MOSU SOURCE CHAT 07/10/29 21:24:51 5940 2 : C MODI SUPPRESSION D'UN ELEMENT 3 : C 4 : SUBROUTINE MOSU(XPROJ,IVU,ICPR,MELEME) 5 : IMPLICIT INTEGER(I-N) 6 : -INC CCREEL 7 : -INC SMELEME 8 : -INC CCGEOME 9 : COMMON/CMODI/LIGMAX,XDEC,YDEC 10 : DIMENSION XTR(10),YTR(10),ZTR(10) 11 : SEGMENT IVU(0) 12 : SEGMENT XPROJ(3,0) 13 : SEGMENT ICPR(0) 14 : SEGMENT ISOM(NBSO) 15 : do i=1,10 16 : ztr(i)=0 17 : enddo 18 : 5 CONTINUE 18 : CALL TRMESS('POINTEZ L''ELEMENT A SUPPRIMER') 18 : CALL MOPF3 18 : CALL TRDIG(XP,YP,INCLE) 18 : CALL TRMESS(' ') 19 : IF (INCLE.EQ.3) RETURN 20 : IPT1=MELEME 21 : SEGACT IPT1*MOD 22 : DO 20 IO=1,MAX(1,LISOUS(/1)) 23 : IF (LISOUS(/1).NE.0) THEN 24 : IPT1=LISOUS(IO) 25 : SEGACT IPT1*MOD 26 : ENDIF 27 : NBNN=IPT1.NUM(/1) 28 : IF (KSURF(IPT1.ITYPEL).NE.0) GOTO 60 29 : C C'EST UNE LIGNE 30 : DO 40 J=1,IPT1.NUM(/2) 31 : IA=ICPR(IPT1.NUM(1,J)) 32 : IB=ICPR(IPT1.NUM(NBNN,J)) 33 : IF (IVU(IA).NE.1) GOTO 40 34 : IF (IVU(IB).NE.1) GOTO 40 35 : XA=XPROJ(1,IA) 36 : YA=XPROJ(2,IA) 37 : XB=XPROJ(1,IB) 38 : YB=XPROJ(2,IB) 39 : SCA=(XP-XA)*(XP-XB)+(YP-YA)*(YP-YB) 40 : IF (SCA.LE.0.) GOTO 500 41 : 40 CONTINUE 42 : GOTO 100 43 : 60 IF (KSURF(IPT1.ITYPEL).NE.IPT1.ITYPEL) GOTO 100 44 : C C'EST UNE SURFACE 45 : NBSO = NBSOM(IPT1.ITYPEL) 46 : IF (NBSO.EQ.0) THEN 47 : C Polygone a N cotes 48 : NBSO = IPT1.NUM(/1) 49 : ENDIF 50 : SEGINI ISOM 51 : DO 61 I=1,ISOM(/1) 52 : ISOM(I)=IBSOM(NSPOS(IPT1.ITYPEL)-1+I) 53 : 61 CONTINUE 54 : DO 62 J=1,IPT1.NUM(/2) 55 : I1=ICPR(IPT1.NUM(ISOM(1),J)) 56 : I2=ICPR(IPT1.NUM(ISOM(2),J)) 57 : I3=ICPR(IPT1.NUM(ISOM(3),J)) 58 : IF (IVU(I1).NE.1) GOTO 62 59 : IF (IVU(I2).NE.1) GOTO 62 60 : IF (IVU(I3).NE.1) GOTO 62 61 : X1=XPROJ(1,I1) 62 : X2=XPROJ(1,I2) 63 : X3=XPROJ(1,I3) 64 : Y1=XPROJ(2,I1) 65 : Y2=XPROJ(2,I2) 66 : Y3=XPROJ(2,I3) 67 : Z1=0. 68 : Z2=0. 69 : Z3=0. 70 : XNORM=(Y2-Y1)*(Z2-Z3)-(Z2-Z1)*(Y2-Y3) 71 : YNORM=(Z2-Z1)*(X2-X3)-(X2-X1)*(Z2-Z3) 72 : ZNORM=(X2-X1)*(Y2-Y3)-(Y2-Y1)*(X2-X3) 73 : DNORM=SQRT(XNORM**2+YNORM**2+ZNORM**2) 74 : XNORM=XNORM/DNORM 75 : YNORM=YNORM/DNORM 76 : ZNORM=ZNORM/DNORM 77 : ANG=0. 78 : I1=ICPR(IPT1.NUM(ISOM(ISOM(/1)),J)) 79 : XV1=XPROJ(1,I1)-XP 80 : YV1=XPROJ(2,I1)-YP 81 : ZV1=0. 82 : DO 63 IS=1,ISOM(/1) 83 : I2=ICPR(IPT1.NUM(ISOM(IS),J)) 84 : XV2=XPROJ(1,I2)-XP 85 : YV2=XPROJ(2,I2)-YP 86 : ZV2=0. 87 : XATA=XNORM*(YV1*ZV2-ZV1*YV2)+YNORM*(ZV1*XV2-XV1*ZV2)+ 88 : # ZNORM*(XV1*YV2-YV1*XV2) 89 : YATA=XV1*XV2+YV1*YV2+ZV1*ZV2 90 : IF (XATA.EQ.0..AND.YATA.EQ.0.) GOTO 500 91 : ANG=ANG+ATAN2(XATA,YATA) 92 : XV1=XV2 93 : YV1=YV2 94 : ZV1=ZV2 95 : 63 CONTINUE 96 : IF (ABS(ANG).GT.XPI) GOTO 500 97 : 62 CONTINUE 98 : SEGSUP ISOM 99 : 100 CONTINUE 100 : 20 CONTINUE 101 : * ON N'A PAS TROUVE ON RECOMMENCE 102 : GOTO 5 103 : * ON A TROUVE ON DESSINE L'ELEMENT EN REDUIT ET EN ROSE 104 : 500 CONTINUE 104 : call insegt(3,iresu) 105 : ITR=1 106 : XECLAT=0.8 107 : IEL=J 107 : CALL CHCOUL(3) 108 : K=IPT1.ITYPEL 109 : IDEP=LPT(K) 110 : IFIN=IDEP+2*LPL(K)-2 111 : IFIN2=IFIN 112 : IF (LPL(K).EQ.0.AND.LPT(K).NE.0)THEN 113 : C Polygone 114 : IFIN =IDEP+2*IPT1.NUM(/1)-2 115 : IFIN2=IFIN -2 116 : ENDIF 117 : I=IEL 118 : XG=0. 119 : YG=0. 120 : N=IPT1.NUM(/1) 121 : DO 510 J=1,N 122 : XG=XG+XPROJ(1,ICPR(IPT1.NUM(J,I))) 123 : YG=YG+XPROJ(2,ICPR(IPT1.NUM(J,I))) 124 : 510 CONTINUE 125 : XG=XG/N 126 : YG=YG/N 127 : I3=0 128 : DO 520 J=IDEP,IFIN,2 129 : IF (J.LE.IFIN2) THEN 130 : I1=ICPR(IPT1.NUM(KSEGM(J),I)) 131 : I2=ICPR(IPT1.NUM(KSEGM(J+1),I)) 132 : ELSE 133 : I1=ICPR(IPT1.NUM(KSEGM(IFIN2+1),I)) 134 : I2=ICPR(IPT1.NUM(KSEGM(1),I)) 135 : ENDIF 136 : XR=XG+(XPROJ(1,I1)-XG)*XECLAT 137 : YR=YG+(XPROJ(2,I1)-YG)*XECLAT 138 : IF (I1.NE.I3) THEN 138 : IF (ITR.NE.1) CALL POLRL(ITR,XTR,YTR,ZTR) 139 : ITR=1 140 : XTR(ITR)=XR 141 : YTR(ITR)=YR 142 : ENDIF 143 : XR=XG+(XPROJ(1,I2)-XG)*XECLAT 144 : YR=YG+(XPROJ(2,I2)-YG)*XECLAT 145 : ITR=ITR+1 146 : XTR(ITR)=XR 147 : YTR(ITR)=YR 148 : I3=I2 149 : 520 CONTINUE 149 : IF (ITR.NE.1) CALL POLRL(ITR,XTR,YTR,ZTR) 150 : * DEFINITIF 151 : IPTSUP=IPT1 152 : IPT1=MELEME 153 : DO 610 IO=1,MAX(1,LISOUS(/1)) 154 : IF (LISOUS(/1).NE.0) IPT1=LISOUS(IO) 155 : IF (IPT1.NE.IPTSUP) GOTO 620 156 : DO 630 IL=IEL,IPT1.NUM(/2)-1 157 : DO 640 IN=1,IPT1.NUM(/1) 158 : IPT1.NUM(IN,IL)=IPT1.NUM(IN,IL+1) 159 : 640 CONTINUE 160 : IPT1.ICOLOR(IL)=IPT1.ICOLOR(IL+1) 161 : 630 CONTINUE 162 : NBNN=IPT1.NUM(/1) 163 : NBELEM=IPT1.NUM(/2)-1 164 : NBREF=0 165 : NBSOUS=0 166 : SEGADJ IPT1 167 : 620 CONTINUE 168 : 610 CONTINUE 169 : * SUPPRIMER LES SOUS-OBJETS VIDES 170 : IF (LISOUS(/1).EQ.0) RETURN 171 : IO1=0 172 : DO 700 IO=1,LISOUS(/1) 173 : IPT1=LISOUS(IO) 174 : IF (IPT1.NUM(/2).EQ.0) THEN 175 : SEGSUP IPT1 176 : GOTO 700 177 : ENDIF 178 : IO1=IO1+1 179 : LISOUS(IO1)=LISOUS(IO) 180 : 700 CONTINUE 181 : NBELEM=0 182 : NBNN=0 183 : NBREF=0 184 : NBSOUS=IO1 185 : IF (NBSOUS.NE.LISOUS(/1)) SEGADJ MELEME 186 : * SI UNE SEULE REFERENCE SUPPRIMER LE CHAPEAU 187 : IF (LISOUS(/1).EQ.1) THEN 188 : IPT1=LISOUS(1) 189 : NBELEM=IPT1.NUM(/2) 190 : NBNN=IPT1.NUM(/1) 191 : NBSOUS=0 192 : NBREF=0 193 : SEGADJ MELEME 194 : ITYPEL=IPT1.ITYPEL 195 : DO 731 J=1,NBELEM 196 : DO 730 I=1,NBNN 197 : NUM(I,J)=IPT1.NUM(I,J) 198 : 730 CONTINUE 199 : ICOLOR(J)=IPT1.ICOLOR(J) 200 : 731 CONTINUE 201 : SEGSUP IPT1 202 : ENDIF 203 : END 204 : 205 : 206 : 207 : 208 : 209 : 210 : 211 : 212 : 213 : 214 : 215 : 216 : 217 : 218 : 219 :
© Cast3M 2003 - All rights reserved.
Disclaimer