1 : C MONL SOURCE CHAT 07/10/29 21:24:48 5940 2 : C MODI NOMMER UN ELEMENT 3 : C 4 : SUBROUTINE MONL(XPROJ,IVU,ICPR,IPTZ) 5 : IMPLICIT INTEGER(I-N) 6 : -INC CCREEL 7 : -INC SMELEME 8 : -INC CCOPTIO 9 : -INC CCGEOME 10 : DIMENSION XTR(40),YTR(40),ztr(40) 11 : CHARACTER*8 ZONE 12 : CHARACTER*19 LEGEND(3) 13 : COMMON/CMODI/LIGMAX,XDEC,YDEC 14 : SEGMENT IVU(0) 15 : SEGMENT XPROJ(3,0) 16 : SEGMENT ICPR(0) 17 : SEGMENT ISOM(NBSO) 18 : do i=1,40 19 : ztr(i)=0 20 : enddo 21 : IPT1=IPTZ 22 : XDPR=XDEC**2 23 : 11 CONTINUE 24 : LEGEND(1)=' ' 25 : LEGEND(2)='Element du maillage' 26 : LEGEND(3)='Element du contour' 26 : CALL MENU(LEGEND,3,19) 26 : CALL TRAFF(ICLE) 27 : IF (ICLE.NE.1.AND.ICLE.NE.2) GOTO 11 28 : IF (ICLE.EQ.2) THEN 28 : CALL ECROBJ('MAILLAGE',IPT1) 28 : CALL PRCONT 28 : CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU) 29 : IF (IERR.NE.0) RETURN 30 : * REACTIVONS LE MAILLAGE A TOUT HASARD 31 : SEGACT IPT1 32 : DO 101 I=1,IPT1.LISOUS(/1) 33 : IPT2=IPT1.LISOUS(I) 34 : SEGACT IPT2 35 : 101 CONTINUE 36 : SEGACT MELEME 37 : NBELEM=NUM(/2) 38 : NBNN=NUM(/1) 38 : CALL CHCOUL(1) 39 : ICOUR=0 40 : ITR=1 41 : DO 10 J=1,NBELEM 42 : DO 20 I=1,NBNN-1 43 : IP=ICPR(NUM(I,J)) 44 : IP1=ICPR(NUM(I+1,J)) 45 : IF (IVU(IP).NE.1) GOTO 20 46 : IF (IVU(IP1).NE.1) GOTO 20 47 : IF (ICOUR.NE.IP) THEN 47 : IF (ITR.GT.1) CALL POLRL(ITR,XTR,YTR,ZTR) 48 : ITR=1 49 : XTR(1)=XPROJ(1,IP) 50 : YTR(1)=XPROJ(2,IP) 51 : ENDIF 52 : ITR=ITR+1 53 : XTR(ITR)=XPROJ(1,IP1) 54 : YTR(ITR)=XPROJ(2,IP1) 55 : IF (ITR.EQ.40) THEN 55 : CALL POLRL(ITR,XTR,YTR,ZTR) 56 : XTR(1)=XTR(ITR) 57 : YTR(1)=YTR(ITR) 58 : ITR=1 59 : ENDIF 60 : ICOUR=IP1 61 : 20 CONTINUE 62 : 10 CONTINUE 62 : CALL POLRL(ITR,XTR,YTR,ZTR) 63 : ITR=1 64 : 40 CONTINUE 64 : CALL TRMESS('Pointez la premiere extremite') 64 : CALL MOPF3 64 : CALL TRDIG(X,Y,INCLE) 65 : IF (INCLE.EQ.3) RETURN 66 : DO 80 IL=1,NUM(/2) 67 : IPT=NUM(1,IL) 68 : IP=ICPR(IPT) 69 : IF (IVU(IP).NE.1) GOTO 80 70 : IF ((X-XPROJ(1,IP))**2+(Y-XPROJ(2,IP))**2.LE.XDPR) GOTO 30 71 : 80 CONTINUE 72 : GOTO 40 73 : 30 IP1 = IPT 74 : 70 CONTINUE 74 : CALL TRMESS('Pointez la deuxieme extremite') 74 : CALL MOPF3 74 : CALL TRDIG(X,Y,INCLE) 75 : IF (INCLE.EQ.3) RETURN 76 : DO 50 IL=1,NUM(/2) 77 : IPT=NUM(1,IL) 78 : IP=ICPR(IPT) 79 : IF (IVU(IP).NE.1) GOTO 50 80 : IF ((X-XPROJ(1,IP))**2+(Y-XPROJ(2,IP))**2.LE.XDPR) GOTO 60 81 : 50 CONTINUE 82 : GOTO 70 83 : 60 IP2=IPT 83 : CALL ECROBJ ('POINT ',IP2) 83 : CALL ECROBJ ('POINT ',IP1) 83 : CALL ECROBJ ('MAILLAGE',MELEME) 83 : CALL COMPRI 83 : CALL LIROBJ ( 'MAILLAGE',IPT2,1,IRETOU) 84 : IF(IERR.NE.0) RETURN 85 : SEGDES MELEME 86 : MELEME=IPT2 87 : SEGACT MELEME 88 : NBELEM=NUM(/2) 89 : NBNN=NUM(/1) 89 : CALL CHCOUL(6) 90 : ICOUR=0 91 : ITR=1 92 : DO 100 J=1,NBELEM 93 : DO 110 I=1,NBNN-1 94 : IP=ICPR(NUM(I,J)) 95 : IP1=ICPR(NUM(I+1,J)) 96 : IF (IVU(IP).NE.1) GOTO 110 97 : IF (IVU(IP1).NE.1) GOTO 110 98 : IF (ICOUR.NE.IP) THEN 98 : IF (ITR.GT.1) CALL POLRL(ITR,XTR,YTR,ZTR) 99 : ITR=1 100 : XTR(1)=XPROJ(1,IP) 101 : YTR(1)=XPROJ(2,IP) 102 : ENDIF 103 : ITR=ITR+1 104 : XTR(ITR)=XPROJ(1,IP1) 105 : YTR(ITR)=XPROJ(2,IP1) 106 : IF (ITR.EQ.40) THEN 106 : CALL POLRL(ITR,XTR,YTR,ZTR) 107 : XTR(1)=XTR(ITR) 108 : YTR(1)=YTR(ITR) 109 : ITR=1 110 : ENDIF 111 : ICOUR=IP1 112 : 110 CONTINUE 113 : 100 CONTINUE 113 : CALL POLRL(ITR,XTR,YTR,ZTR) 114 : ITR=1 114 : CALL TRGET('Donnez un nom si necessaire :',ZONE) 115 : IF (ZONE(1:1).EQ.' ') THEN 116 : SEGSUP MELEME 117 : RETURN 118 : ENDIF 118 : CALL NOMOBJ('MAILLAGE',ZONE,MELEME) 119 : RETURN 120 : ENDIF 121 : * RECHERCHE D'ELEMENT 122 : IPPT=0 123 : IEEL=0 124 : * ON CREE UN RESULTAT VIDE POUR RECEUILLIR LES ELEMENTS DESIGNES 125 : NBNN=0 126 : NBELEM=0 127 : NBSOUS=0 128 : NBREF=0 129 : SEGINI IPT8 130 : MELEME=IPT1 130 : CALL TRMESS('Pointez les elements a nommer. Pointez 2 fois le ' 131 : # //'meme pour terminer') 132 : 400 CONTINUE 132 : CALL TRDIG(XP,YP,INCLE) 133 : IF (INCLE.EQ.3) GOTO 650 134 : IPT1=MELEME 135 : SEGACT IPT1 136 : DO 220 IO=1,MAX(1,LISOUS(/1)) 137 : IF (LISOUS(/1).NE.0) THEN 138 : IPT1=LISOUS(IO) 139 : SEGACT IPT1 140 : ENDIF 141 : NBNN=IPT1.NUM(/1) 142 : IF (KSURF(IPT1.ITYPEL).NE.0) GOTO 260 143 : * C'EST UNE LIGNE 144 : DO 240 J=1,IPT1.NUM(/2) 145 : IA=ICPR(IPT1.NUM(1,J)) 146 : IB=ICPR(IPT1.NUM(NBNN,J)) 147 : IF (IVU(IA).NE.1) GOTO 240 148 : IF (IVU(IB).NE.1) GOTO 240 149 : XA=XPROJ(1,IA) 150 : YA=XPROJ(2,IA) 151 : XB=XPROJ(1,IB) 152 : YB=XPROJ(2,IB) 153 : SCA=(XP-XA)*(XP-XB)+(YP-YA)*(YP-YB) 154 : IF (SCA.LE.0.) GOTO 500 155 : 240 CONTINUE 156 : GOTO 1000 157 : 260 IF (KSURF(IPT1.ITYPEL).NE.IPT1.ITYPEL) GOTO 1000 158 : * C'EST UNE SURFACE 159 : NBSO = NBSOM(IPT1.ITYPEL) 160 : IF (NBSO.EQ.0) THEN 161 : C Polygone a N cotes 162 : NBSO = IPT1.NUM(/1) 163 : ENDIF 164 : SEGINI ISOM 165 : DO 261 I=1,ISOM(/1) 166 : ISOM(I)=IBSOM(NSPOS(IPT1.ITYPEL)-1+I) 167 : 261 CONTINUE 168 : DO 262 J=1,IPT1.NUM(/2) 169 : I1=ICPR(IPT1.NUM(ISOM(1),J)) 170 : I2=ICPR(IPT1.NUM(ISOM(2),J)) 171 : I3=ICPR(IPT1.NUM(ISOM(3),J)) 172 : IF (IVU(I1).NE.1) GOTO 262 173 : IF (IVU(I2).NE.1) GOTO 262 174 : IF (IVU(I3).NE.1) GOTO 262 175 : X1=XPROJ(1,I1) 176 : X2=XPROJ(1,I2) 177 : X3=XPROJ(1,I3) 178 : Y1=XPROJ(2,I1) 179 : Y2=XPROJ(2,I2) 180 : Y3=XPROJ(2,I3) 181 : Z1=0. 182 : Z2=0. 183 : Z3=0. 184 : XNORM=(Y2-Y1)*(Z2-Z3)-(Z2-Z1)*(Y2-Y3) 185 : YNORM=(Z2-Z1)*(X2-X3)-(X2-X1)*(Z2-Z3) 186 : ZNORM=(X2-X1)*(Y2-Y3)-(Y2-Y1)*(X2-X3) 187 : DNORM=SQRT(XNORM**2+YNORM**2+ZNORM**2) 188 : XNORM=XNORM/DNORM 189 : YNORM=YNORM/DNORM 190 : ZNORM=ZNORM/DNORM 191 : ANG=0. 192 : I1=ICPR(IPT1.NUM(ISOM(ISOM(/1)),J)) 193 : XV1=XPROJ(1,I1)-XP 194 : YV1=XPROJ(2,I1)-YP 195 : ZV1=0. 196 : DO 263 IS=1,ISOM(/1) 197 : I2=ICPR(IPT1.NUM(ISOM(IS),J)) 198 : XV2=XPROJ(1,I2)-XP 199 : YV2=XPROJ(2,I2)-YP 200 : ZV2=0. 201 : XATA=XNORM*(YV1*ZV2-ZV1*YV2)+YNORM*(ZV1*XV2-XV1*ZV2)+ 202 : # ZNORM*(XV1*YV2-YV1*XV2) 203 : YATA=XV1*XV2+YV1*YV2+ZV1*ZV2 204 : IF (XATA.EQ.0..AND.YATA.EQ.0.) GOTO 500 205 : ANG=ANG+ATAN2(XATA,YATA) 206 : XV1=XV2 207 : YV1=YV2 208 : ZV1=ZV2 209 : 263 CONTINUE 210 : IF (ABS(ANG).GT.XPI) GOTO 500 211 : 262 CONTINUE 212 : SEGSUP ISOM 213 : 1000 CONTINUE 214 : 220 CONTINUE 215 : * ON N'A PAS TROUVE ON RECOMMENCE 216 : GOTO 400 217 : * ON A TROUVE ON DESSINE L'ELEMENT EN REDUIT ET EN ROSE 218 : 500 CONTINUE 219 : IEL=J 220 : IF (IPT1.EQ.IPPT.AND.IEL.EQ.IEEL) GOTO 650 221 : IPPT=IPT1 222 : IEEL=IEL 223 : XECLAT=0.8 223 : CALL CHCOUL(1) 224 : K=IPT1.ITYPEL 225 : IDEP=LPT(K) 226 : IFIN=IDEP+2*LPL(K)-2 227 : IFIN2=IFIN 228 : IF (LPL(K).EQ.0.AND.LPT(K).NE.0)THEN 229 : C Polygone 230 : IFIN =IDEP+2*IPT1.NUM(/1)-2 231 : IFIN2=IFIN -2 232 : ENDIF 233 : I=IEL 234 : XG=0. 235 : YG=0. 236 : N=IPT1.NUM(/1) 237 : DO 510 J=1,N 238 : XG=XG+XPROJ(1,ICPR(IPT1.NUM(J,I))) 239 : YG=YG+XPROJ(2,ICPR(IPT1.NUM(J,I))) 240 : 510 CONTINUE 241 : XG=XG/N 242 : YG=YG/N 243 : I3=0 244 : ITR=1 245 : DO 520 J=IDEP,IFIN,2 246 : IF (J.LE.IFIN2) THEN 247 : I1=ICPR(IPT1.NUM(KSEGM(J),I)) 248 : I2=ICPR(IPT1.NUM(KSEGM(J+1),I)) 249 : ELSE 250 : I1=ICPR(IPT1.NUM(KSEGM(IFIN2+1),I)) 251 : I2=ICPR(IPT1.NUM(KSEGM(1),I)) 252 : ENDIF 253 : XR=XG+(XPROJ(1,I1)-XG)*XECLAT 254 : YR=YG+(XPROJ(2,I1)-YG)*XECLAT 255 : IF (I1.NE.I3) THEN 255 : IF (ITR.GT.1) CALL POLRL(ITR,XTR,YTR,ZTR) 256 : ITR=1 257 : XTR(ITR)=XR 258 : YTR(ITR)=YR 259 : ENDIF 260 : XR=XG+(XPROJ(1,I2)-XG)*XECLAT 261 : YR=YG+(XPROJ(2,I2)-YG)*XECLAT 262 : ITR=ITR+1 263 : XTR(ITR)=XR 264 : YTR(ITR)=YR 265 : I3=I2 266 : 520 CONTINUE 266 : IF (ITR.GT.1) CALL POLRL(ITR,XTR,YTR,ZTR) 267 : ITR=1 268 : * ON MET DANS LE RESULTAT 269 : ITYP=IPT1.ITYPEL 270 : 630 CONTINUE 271 : DO 600 IO=1,IPT8.LISOUS(/1) 272 : IPT2=IPT8.LISOUS(IO) 273 : IF (ITYP.NE.IPT2.ITYPEL) GOTO 600 274 : NBNN=IPT2.NUM(/1) 275 : NBSOUS=0 276 : NBREF=0 277 : NBELEM=IPT2.NUM(/2)+1 278 : SEGADJ IPT2 279 : DO 610 I=1,NBNN 280 : IPT2.NUM(I,NBELEM)=IPT1.NUM(I,IEL) 281 : 610 CONTINUE 282 : IPT2.ICOLOR(NBELEM)=IPT1.ICOLOR(NBELEM) 283 : GOTO 620 284 : 600 CONTINUE 285 : NBNN=IPT1.NUM(/1) 286 : NBELEM=0 287 : NBREF=0 288 : NBSOUS=0 289 : SEGINI IPT2 290 : IPT2.ITYPEL=IPT1.ITYPEL 291 : NBNN=0 292 : NBELEM=0 293 : NBREF=0 294 : NBSOUS=IPT8.LISOUS(/1)+1 295 : SEGADJ IPT8 296 : IPT8.LISOUS(NBSOUS)=IPT2 297 : GOTO 630 298 : * OK ON PEUT CONTINUER 299 : 620 CONTINUE 300 : GOTO 400 301 : 650 CONTINUE 302 : * SI UN SEUL SOUS-OBJET ON SIMPLIFIE LA STRUCTURE 303 : IF (IPT8.LISOUS(/1).EQ.1) THEN 304 : IPT7=IPT8 305 : IPT8=IPT7.LISOUS(1) 306 : SEGSUP IPT7 307 : ENDIF 308 : IF (IPT8.NUM(/2).EQ.0) THEN 309 : SEGSUP IPT8 310 : RETURN 311 : ENDIF 312 : * ON DEMANDE LE NOM 312 : CALL TRGET('Donnez un nom si necessaire:',ZONE) 313 : IF (ZONE(1:1).EQ.' ') THEN 314 : SEGSUP IPT8 315 : RETURN 316 : ENDIF 316 : CALL NOMOBJ('MAILLAGE',ZONE,IPT8) 317 : RETURN 318 : END 319 : 320 : 321 : 322 : 323 : 324 : 325 : 326 : 327 : 328 : 329 : 330 : 331 : 332 : 333 :
© Cast3M 2003 - All rights reserved.
Disclaimer