1 : C DICHO3 SOURCE PV 13/02/28 21:15:00 7702 2 : C NOUVELLE VERSION DE DICHO 3 : C CE SOUS-PROGRAMME SERT A RESOUDRE LES SEGMENTS EN PARTIE CACHES 4 : C ADAPTE A GIBI 5 : C 1995 TRAC option FACB et FASB P.PEGON JRC-ISPRA 6 : C 7 : C PP FACE avec trait blanc 8 : SUBROUTINE DICHO3(XPROJ,MELEME,ICPR,XMIN,XMAX,YMIN,YMAX,IVU,NTSEG, 9 : # NELEM,IICOL,IDEFCO,lblanc,LTSEG) 10 : C PP # NELEM,IICOL,IDEFCO) 11 : C 12 : C TABLEAUX: NTELCL ELEMENTS CLASSES PAR ZONE 13 : C NTSEG SEGMENTS DOUTEUX 14 : C NAUX TABLEAU DE TRAVAIL 15 : C KON TABLEAU DES ELEMENTS TOUCHANT UN NOEUD 16 : C+PP trait blanc 17 : IMPLICIT INTEGER(I-N) 18 : logical lblanc 19 : C+PP 20 : DIMENSION XTR(2),YTR(2),ZTR(2) 21 : REAL*8 A,B,C 22 : REAL*8 XKK,XNN,XRAP,DNOM,DNUM,U,XPAR 23 : SEGMENT NTSEG(0) 24 : SEGMENT /XPROJ/(X(3,1)) 25 : SEGMENT IVU(NUMNP) 26 : SEGMENT ICPR(0) 27 : SEGMENT /TRAV1/(NTELEM(NELEM)) 28 : SEGMENT /TRAV2/(NTELCL(NREL),NAUX(NREL),IJK(4*NBZONE+2*NDEC+10)) 29 : SEGMENT /TRAV3/(IKON(IVU(/1))) 30 : SEGMENT /TRAV4/(KON(ISUP,IVU(/1))) 31 : SEGMENT /TRAV5/(DSTEL(NREL),NHZ(NELZON+2)) 32 : -INC CCOPTIO 33 : -INC CCGEOME 34 : -INC CCREEL 35 : -INC SMELEME 36 : ZTR(1)=0 37 : ZTR(2)=0 38 : IF (NTSEG(/1).NE.0) GOTO 1 39 : SEGSUP NTSEG 40 : RETURN 41 : C RIEN A FAIRE 42 : 1 A=30. 42 : * CALL LIRREE(A,0,IRETOU) GENANT EN FULLSCREEN 43 : SEGACT ICPR 44 : C ON REMPLIT NTELEM TABLEAU DE REGROUPEMENT DES ELEMENTS 45 : SEGINI TRAV1 46 : NREL=0 47 : IPT1=MELEME 48 : SEGACT MELEME 49 : DO 3001 IOB=1,MAX(1,LISOUS(/1)) 50 : IF (LISOUS(/1).NE.0) THEN 51 : IPT1=LISOUS(IOB) 52 : SEGACT IPT1 53 : ENDIF 54 : IF (LTEL(1,IPT1.ITYPEL).EQ.0) GOTO 3003 55 : IPB=IOB*NELEM 56 : DO 3002 I=1,IPT1.NUM(/2) 57 : DO 3005 J=1,IPT1.NUM(/1) 58 : IF (IVU(ICPR(IPT1.NUM(J,I))).GT.0) GOTO 3006 59 : 3005 CONTINUE 60 : GOTO 3002 61 : 3006 CONTINUE 62 : NREL=NREL+1 63 : NTELEM(NREL)=IPB+I 64 : 3002 CONTINUE 65 : 3003 CONTINUE 66 : 3001 CONTINUE 67 : C NB MOYEN DE PTS PAR ZONE 68 : RAP=(YMAX-YMIN)/(XMAX-XMIN) 69 : NBZONE=REAL(NREL)/A+1 70 : NDEC=SQRT(REAL(NBZONE)/RAP) 71 : IF (NDEC.EQ.0) NDEC=1 72 : MDEC=NBZONE/NDEC 73 : IF (MDEC.EQ.0) MDEC=1 74 : NBZONE=NDEC*MDEC 75 : IF (IIMPI.EQ.1) WRITE (IOIMP,9912) NBZONE 76 : 9912 FORMAT (' NOMBRE DE ZONES ',I6) 77 : XDIST=XMAX-XMIN 78 : YDIST=YMAX-YMIN 79 : XDEC=XDIST/NDEC*1.00001 80 : YDEC=YDIST/MDEC*1.00001 81 : NUMNP=IVU(/1) 82 : SMO=1E-5*XDIST*YDIST/NUMNP 83 : C REMPLISSAGE DE KON TABLEAU ELEM (DE NTELEM) TOUCHANT NOEUD 84 : SEGINI TRAV3 85 : DO 5011 I=1,NREL 86 : IOB=(NTELEM(I)-1)/NELEM 87 : IF (LISOUS(/1).NE.0) THEN 88 : IPT1=LISOUS(IOB) 89 : ELSE 90 : IPT1=MELEME 91 : ENDIF 92 : IEL=NTELEM(I)-IOB*NELEM 93 : DO 5012 J=1,IPT1.NUM(/1) 94 : K=ICPR(IPT1.NUM(J,IEL)) 95 : IKON(K)=IKON(K)+1 96 : 5012 CONTINUE 97 : 5011 CONTINUE 98 : ISUP=0 99 : DO 5013 I=1,IKON(/1) 100 : ISUP=MAX(ISUP,IKON(I)) 101 : 5013 CONTINUE 102 : SEGINI TRAV4 103 : DO 5015 I=1,NREL 104 : IOB=(NTELEM(I)-1)/NELEM 105 : IF (LISOUS(/1).NE.0) THEN 106 : IPT1=LISOUS(IOB) 107 : ELSE 108 : IPT1=MELEME 109 : ENDIF 110 : IEL=NTELEM(I)-IOB*NELEM 111 : DO 5016 J=1,IPT1.NUM(/1) 112 : K=ICPR(IPT1.NUM(J,IEL)) 113 : KON(IKON(K),K)=NTELEM(I) 114 : IKON(K)=IKON(K)-1 115 : 5016 CONTINUE 116 : 5015 CONTINUE 117 : SEGSUP TRAV3 118 : C REMPLISSAGE DE NAUX(I)=ZONE DE L'ELEMENT NTELEM(I) 119 : SEGINI TRAV2 120 : DO 10 I=1,IJK(/1) 121 : 10 IJK(I)=0 122 : DO 26 I=1,NREL 123 : IOB=(NTELEM(I)-1)/NELEM 124 : IF (LISOUS(/1).NE.0) THEN 125 : IPT1=LISOUS(IOB) 126 : ELSE 127 : IPT1=MELEME 128 : ENDIF 129 : IEL=NTELEM(I)-IOB*NELEM 130 : IDEC=0 131 : IDEC2=0 132 : IDEC3=0 133 : INOEUD=ICPR(IPT1.NUM(1,IEL)) 134 : NAUXI=INT(real((X(1,INOEUD)-XMIN)/XDEC))+1+INT(real((X(2,INOEUD) 135 : # -YMIN)/YDEC))*NDEC 136 : DO 21 J=2,IPT1.NUM(/1) 137 : INOEUD=ICPR(IPT1.NUM(J,IEL)) 138 : IZONE=INT(real((X(1,INOEUD)-XMIN)/XDEC))+1+ 139 : # INT(real((X(2,INOEUD)-YMIN)/YDEC))*NDEC 140 : IF (NAUXI.EQ.IZONE) GOTO 21 141 : IF (IDEC.EQ.0) IDEC=IZONE 142 : IF (IDEC.EQ.IZONE) GOTO 21 143 : IF (IDEC2.EQ.0) IDEC2=IZONE 144 : IF (IDEC2.EQ.IZONE) GOTO 21 145 : IF (IDEC3.EQ.0) IDEC3=IZONE 146 : IF (IDEC3.EQ.IZONE) GOTO 21 147 : NAUXI=0 148 : GOTO 20 149 : 21 CONTINUE 150 : IF (IDEC.EQ.0) GOTO 20 151 : IDECC=NAUXI 152 : IF (IDEC2.NE.0) GOTO 30 153 : IVALID=ABS(IDECC-IDEC) 154 : IF (IVALID.NE.1) GOTO 22 155 : NAUXI=MIN(IDECC,IDEC)+NBZONE+1 156 : GOTO 20 157 : 22 IF (IVALID.NE.NDEC) GOTO 23 158 : NAUXI=MIN(IDECC,IDEC)+NBZONE+1+NBZONE+NDEC 159 : GOTO 20 160 : 23 IF (IVALID.NE.NDEC+1) GOTO 24 161 : NAUXI=MIN(IDECC,IDEC)+NBZONE+1+NBZONE+NDEC+NBZONE+NDEC+1 162 : GOTO 20 163 : 24 IF (IVALID.NE.NDEC-1) GOTO 25 164 : NAUXI=MIN(IDECC,IDEC)-1+NBZONE+1+NBZONE+NDEC+NBZONE+NDEC+1 165 : GOTO 20 166 : 25 NAUXI=0 167 : GOTO 20 168 : 30 IF (IDEC3.NE.0) GOTO 33 169 : I1=MIN(IDECC,IDEC,IDEC2) 170 : I3=MAX(IDECC,IDEC,IDEC2) 171 : I2=IDECC+IDEC+IDEC2-I1-I3 172 : IAUX=I2-I1 173 : IF (IAUX.EQ.1) GOTO 31 174 : IF (IAUX.NE.NDEC) GOTO 32 175 : IF (I3-I2.NE.1) GOTO 25 176 : NAUXI=I1+NBZONE+1+NBZONE+NDEC+NBZONE+NDEC+1 177 : GOTO 20 178 : 32 IF (IAUX.NE.NDEC-1) GOTO 25 179 : IF (I3-I2.NE.1) GOTO 25 180 : NAUXI=I1-1+NBZONE+1+NBZONE+NDEC+NBZONE+NDEC+1 181 : GOTO 20 182 : 31 IF (I3-I2.NE.NDEC.AND.I3-I2.NE.NDEC-1) GOTO 25 183 : NAUXI=I1+NBZONE+1+NBZONE+NDEC+NBZONE+NDEC+1 184 : GOTO 20 185 : 33 I1=MIN(IDECC,IDEC,IDEC2,IDEC3) 186 : I4=MAX(IDECC,IDEC,IDEC2,IDEC3) 187 : IF (I4-I1.NE.NDEC+1) GOTO 25 188 : IF (IDECC+IDEC+IDEC2+IDEC3.NE.2*(I1+I4)) GOTO 25 189 : IF (IDECC*IDEC*IDEC2*IDEC3.NE.I1*(I1+1)*(I4-1)*I4) GOTO 25 190 : NAUXI=I1+NBZONE+1+NBZONE+NDEC+NBZONE+NDEC+1 191 : 20 CONTINUE 192 : NAUX(I)=NAUXI 193 : 26 CONTINUE 194 : C LE TABLEAU NAUX EST REMPLI 195 : C ON REMPLIT LE TABLEAU DE POINTEUR IJK (+1) 196 : DO 50 I=1,NREL 197 : IJK(NAUX(I)+1)=IJK(NAUX(I)+1)+1 198 : 50 CONTINUE 199 : NELZON=IJK(1) 200 : DO 51 I=2,IJK(/1) 201 : NELZON=MAX(NELZON,IJK(I)) 202 : 51 IJK(I)=IJK(I)+IJK(I-1) 203 : C CLASSEMENT DES ELEMENTS DANS NTELCL 204 : DO 60 I=1,NREL 205 : IAD=IJK(NAUX(I)+1) 206 : NTELCL(IAD)=NTELEM(I) 207 : IJK(NAUX(I)+1)=IAD-1 208 : 60 CONTINUE 209 : C CLASSEMENT DES ELEMENTS DANS CHAQUE ZONE PAR LA DISTANCE 210 : IF (IIMPI.NE.0) WRITE (IOIMP,9914) NELZON 211 : 9914 FORMAT(' NOMBRE MAX D''ELEMENT PAR ZONE ',I6) 212 : SEGSUP TRAV1 213 : SEGINI TRAV5 214 : DO 71 IW=2,IJK(/1) 215 : IDEB=IJK(IW-1)+1 216 : IFIN=IJK(IW) 217 : IF (IDEB.GT.IFIN) GOTO 71 218 : IDIFF=IFIN-IDEB+1 219 : DO 72 I=IDEB,IFIN 220 : IREL=NTELCL(I) 221 : IOB=(IREL-1)/NELEM 222 : IF (LISOUS(/1).NE.0) THEN 223 : IPT1=LISOUS(IOB) 224 : ELSE 225 : IPT1=MELEME 226 : ENDIF 227 : IEL=IREL-IOB*NELEM 228 : C# DSTEL(I)=XGRAND 229 : DSTEL(I)=XSGRAN 230 : C ON CONSIDERE SEULEMENT LES SEGMENTS DONT AU MOINS UN POINT EST VU 231 : IDEP=LPT(IPT1.ITYPEL) 232 : IFIN1=LPT(IPT1.ITYPEL)+(LPL(IPT1.ITYPEL)-1)*2 233 : IFIN2=IFIN1 234 : IF (LPL(IPT1.ITYPEL).EQ.0.AND.LPT(IPT1.ITYPEL).NE.0)THEN 235 : C Polygone 236 : IFIN1=IDEP+2*IPT1.NUM(/1)-2 237 : IFIN2=IFIN1 -2 238 : ENDIF 239 : DO 73 ISEG=IDEP,IFIN1,2 240 : IF (ISEG.LE.IFIN2) THEN 241 : IP1=ICPR(IPT1.NUM(KSEGM(ISEG),IEL)) 242 : IP2=ICPR(IPT1.NUM(KSEGM(ISEG+1),IEL)) 243 : ELSE 244 : C Polygone 245 : IP1=ICPR(IPT1.NUM(KSEGM(IFIN2+1),IEL)) 246 : IP2=ICPR(IPT1.NUM(KSEGM(1),IEL)) 247 : ENDIF 248 : IF (IVU(IP1).NE.1.AND.IVU(IP2).NE.1) GOTO 73 249 : DSTEL(I)=MIN(DSTEL(I),X(3,IP1),X(3,IP2)) 250 : 73 CONTINUE 251 : 72 CONTINUE 252 : NHZ(1)=1 253 : NHZ(2)=IFIN-IDEB+1 254 : IZM=0 255 : IZ=2 256 : 74 IZ=IZ-1 257 : IF (IZ.LE.0) GOTO 75 258 : IPB=NHZ(IZ*2-1) 259 : IPH=NHZ(IZ*2) 260 : IF (IPB.GE.IPH) GOTO 74 261 : JPB=IPB-1 262 : JPH=IPH+1 263 : C CALCUL DU PIVOT 264 : RPV=(DSTEL(IPB+IDEB-1)+DSTEL(IPH+IDEB-1))/2. 265 : 77 JPB=JPB+1 266 : IF (JPH.EQ.JPB) GOTO 80 267 : IF (DSTEL(JPB+IDEB-1).GE.RPV) GOTO 78 268 : GOTO 77 269 : 78 JPH=JPH-1 270 : IF (JPH.EQ.JPB) GOTO 80 271 : IF (DSTEL(JPH+IDEB-1).LE.RPV) GOTO 79 272 : GOTO 78 273 : 79 IAUX=NTELCL(JPH+IDEB-1) 274 : RAUX=DSTEL(JPH+IDEB-1) 275 : NTELCL(JPH+IDEB-1)=NTELCL(JPB+IDEB-1) 276 : DSTEL(JPH+IDEB-1)=DSTEL(JPB+IDEB-1) 277 : NTELCL(JPB+IDEB-1)=IAUX 278 : DSTEL(JPB+IDEB-1)=RAUX 279 : GOTO 77 280 : C JPH=JPB MAIS ATTENTION PEUT ETRE A L'EXTERIEUR 281 : 80 IF (JPB.GE.IPB) GOTO 81 282 : JPB=JPB+1 283 : JPH=JPH+2 284 : GOTO 84 285 : 81 IF (JPH.LE.IPH) GOTO 82 286 : JPB=JPB-2 287 : JPH=JPH-1 288 : GOTO 84 289 : 82 IF (DSTEL(JPB+IDEB-1).GE.RPV) GOTO 87 290 : IF (JPH.EQ.IPH) GOTO 83 291 : 86 JPH=JPH+1 292 : GOTO 84 293 : 87 IF (JPB.EQ.IPB) GOTO 86 294 : 83 JPB=JPB-1 295 : 84 IF (JPB.EQ.IPB) GOTO 85 296 : NHZ(2*IZ)=JPB 297 : IZ=IZ+1 298 : 85 IF (JPH.EQ.IPH) GOTO 74 299 : NHZ(2*IZ)=IPH 300 : NHZ(2*IZ-1)=JPH 301 : IZ=IZ+1 302 : GOTO 74 303 : 75 CONTINUE 304 : 71 CONTINUE 305 : C 306 : C ON ABORDE MAINTENANT LA BOUCLE ON L'ON BALAYE LES SEGMENTS EN PARTIE 307 : C VUS. 308 : ICOLE=0 309 : C EN FAIT IL Y A NBCOUL+1 COULEUR (+ EFFACEMENT) 310 : DO 99 ICOLE=0,NBCOUL+1 310 : C PP CALL CHCOUL(ICOLE) 311 : C+PP trait blanc 312 : IF (lblanc) THEN 312 : CALL CHCOUL(0) 313 : ELSE 313 : CALL CHCOUL(ICOLE) 314 : ENDIF 315 : C+PP 316 : DO 100 L=1,LTSEG,3 317 : IPVU=NTSEG(L) 318 : IPCA=NTSEG(L+1) 319 : IF (IDEFCO.EQ.1.AND.IICOL.NE.NTSEG(L+2)) GOTO 100 320 : IF (ICOLE.NE.NTSEG(L+2)) GOTO 100 321 : IREL=-IVU(IPCA) 322 : IOB=(IREL-1)/NELEM 323 : IF (LISOUS(/1).NE.0) THEN 324 : if (iob.eq.0) goto 100 325 : IPT1=LISOUS(IOB) 326 : ELSE 327 : IPT1=MELEME 328 : ENDIF 329 : IEL=IREL-IOB*NELEM 330 : COXCA=X(1,IPCA) 331 : COYCA=X(2,IPCA) 332 : COZCA=X(3,IPCA) 333 : COXVU=X(1,IPVU) 334 : COYVU=X(2,IPVU) 335 : COZVU=X(3,IPVU) 336 : PARAM=0.9995 337 : JAC=1 338 : IOPT=0 339 : * write (6,*) ' 1 iob,ipt1 ',iob,ipt1 340 : 150 CONTINUE 341 : LA=0 342 : ISA=0 343 : GOTO 2600 344 : 2602 CONTINUE 345 : IF (ISA.EQ.0) GOTO 151 346 : C ON VA BOUCLER POUR ETUDIER LES ELEMENTS QUI TOUCHENT LE 347 : C SEGMENT ISA ISB 348 : C ON UTILISE LE TABLEAU KON DES ELEM QUI CONTIENNENT UN POINT 349 : IOPT=0 350 : * DO 2500 LA=1,ISUP PROBLEME ON RENTRE DANS LA BOUCLE EN 2600 351 : LA=1 352 : 25000 CONTINUE 353 : LAL=KON(LA,ISA) 354 : IF (LAL.EQ.0) GOTO 2501 355 : IF (LAL.EQ.IREL) GOTO 2500 356 : * DO 2502 LB=1,ISUP PROBLEME ON RENTRE DANS LA BOUCLE EN 2600 357 : LB=1 358 : 25020 CONTINUE 359 : LBL=KON(LB,ISB) 360 : IF (LBL.EQ.0) GOTO 2503 361 : IF (LAL.NE.LBL) GOTO 2502 362 : IF (LBL.EQ.IREL) GOTO 2502 363 : IREL=LAL 364 : IOB=(IREL-1)/NELEM 365 : IF (LISOUS(/1).NE.0) THEN 366 : IPT1=LISOUS(IOB) 367 : ELSE 368 : IPT1=MELEME 369 : ENDIF 370 : IEL=IREL-IOB*NELEM 371 : * write (6,*) ' 2 iob,ipt1 ',iob,ipt1 372 : 2600 CONTINUE 373 : * write (6,*) ' itypel ',ipt1.itypel 374 : IDEP=LPT(IPT1.ITYPEL) 375 : IFIN=IDEP+(LPL(IPT1.ITYPEL)-1)*2 376 : IFIN2=IFIN 377 : IF (LPL(IPT1.ITYPEL).EQ.0.AND.LPT(IPT1.ITYPEL).NE.0)THEN 378 : C Polygone 379 : IFIN=IDEP+2*IPT1.NUM(/1)-2 380 : IFIN2=IFIN -2 381 : ENDIF 382 : JIC=0 383 : JOC=0 384 : DO 101 I=IDEP,IFIN,2 385 : IF (I.LE.IFIN2) THEN 386 : IP1=ICPR(IPT1.NUM(KSEGM(I),IEL)) 387 : IP2=ICPR(IPT1.NUM(KSEGM(I+1),IEL)) 388 : ELSE 389 : C Polygone 390 : IP1=ICPR(IPT1.NUM(KSEGM(IFIN2+1),IEL)) 391 : IP2=ICPR(IPT1.NUM(KSEGM(1),IEL)) 392 : ENDIF 393 : IF (IP1.EQ.IPVU) GOTO 2005 394 : IF (IP2.EQ.IPVU) GOTO 2008 395 : IF (IVU(IP1).NE.1.AND.IVU(IP2).NE.1) GOTO 101 396 : XIP1=X(1,IP1) 397 : YIP1=X(2,IP1) 398 : XIP2=X(1,IP2) 399 : YIP2=X(2,IP2) 400 : C ON CALCULE LA COORDONNEE PARAMETRIQUE DU PT INTERSECTION 401 : DNOM=(COXCA-COXVU)*(YIP2-YIP1)-(COYCA-COYVU)*(XIP2-XIP1) 402 : IF (DNOM.EQ.0.) GOTO 101 403 : DNUM=(COYVU-YIP1)*(XIP2-COXVU)-(COYVU-YIP2)*(XIP1-COXVU) 404 : U=DNUM/DNOM 405 : FOX=COXVU+U*(COXCA-COXVU) 406 : FOY=COYVU+U*(COYCA-COYVU) 407 : IF ((FOX-XIP1)*(FOX-XIP2)+(FOY-YIP1)*(FOY-YIP2).GT.SMO) 408 : # GOTO 101 409 : IF (U.LT.-5E-4.OR.U.GT.PARAM) GOTO 101 410 : JAC=1 411 : JIC=1 412 : ISA=IP1 413 : ISB=IP2 414 : PARAM=U-5E-4 415 : IF (PARAM.GT.1E-4) GOTO 101 416 : GOTO 100 417 : 2005 IF (IP2.EQ.IPCA) GOTO 101 418 : JOC=1 419 : GOTO 101 420 : 2008 IF (IP1.EQ.IPCA) GOTO 101 421 : JOC=1 422 : C ON NE DESSINE RIEN ? 423 : 101 CONTINUE 424 : IF (JAC.LE.0) PARAM=PARAM-5E-3 425 : IF (PARAM.LT.0.) GOTO 100 426 : COX=COXVU+PARAM*(COXCA-COXVU) 427 : COY=COYVU+PARAM*(COYCA-COYVU) 428 : CDIST=COZVU+PARAM*(COZCA-COZVU) 429 : IF (JOC.NE.0) GOTO 100 430 : IF (JIC.EQ.0) GOTO 2603 431 : IF (JAC.EQ.-5) GOTO 2601 432 : JAC=JAC-1 433 : * TEST DES ELEMENTS CONTENANT LE SEGMENT 434 : GOTO 2602 435 : 2603 CONTINUE 436 : IF (LA.EQ.0) GOTO 2602 437 : 2502 CONTINUE 438 : LB=LB+1 439 : IF (LB.LE.ISUP) GOTO 25020 440 : 2503 CONTINUE 441 : 2500 CONTINUE 442 : LA=LA+1 443 : IF (LA.LE.ISUP) GOTO 25000 444 : 2501 CONTINUE 445 : * PLUS D'ELEMENT TESTABLE RECHERCHE FINALE 446 : C REGARDONS SI UN ELEMENT CACHE CE POINT 447 : C D'ABORD TROUVONS SA ZONE 448 : C ON BOUCLE SUR TOUS LES ELEMENTS 449 : 151 CONTINUE 450 : IF (IOPT.EQ.1) GOTO 100 451 : KNN=INT(real((COX-XMIN)/XDEC))+1+INT(real((COY-YMIN)/YDEC))*NDEC 452 : IOPT=1 453 : DO 140 IBAL=1,10 454 : GOTO (130,131,132,133,134,135,136,137,138,139),IBAL 455 : 130 KN=KNN 456 : GOTO 110 457 : 131 KN=KNN-1+NBZONE+1 458 : GOTO 110 459 : 132 KN=KNN+(NBZONE)+1 460 : GOTO 110 461 : 133 KN=KNN-NDEC+(NBZONE+1)+(NBZONE+NDEC) 462 : GOTO 110 463 : 134 KN=KNN+(NBZONE+1)+(NBZONE+NDEC) 464 : GOTO 110 465 : 135 KN=KNN+(NBZONE+1)+(NBZONE+NDEC)+(NBZONE+NDEC+1) 466 : GOTO 110 467 : 136 KN=KNN-1+(NBZONE+1)+(NBZONE+NDEC)+(NBZONE+NDEC+1) 468 : GOTO 110 469 : 137 KN=KNN-NDEC+(NBZONE+1)+(NBZONE+NDEC)+(NBZONE+NDEC+1) 470 : GOTO 110 471 : 138 KN=KNN-NDEC-1+(NBZONE+1)+(NBZONE+NDEC)+(NBZONE+NDEC+1) 472 : GOTO 110 473 : 139 KN=0 474 : GOTO 110 475 : 110 KPU=IJK(KN+1+1) 476 : KPV=IJK(KN+1)+1 477 : IF (KPU.LT.KPV) GOTO 140 478 : IELD=1 479 : DO 112 KK=KPV,KPU 480 : IF (IELD.EQ.0) GOTO 140 481 : IELD=0 482 : IF (DSTEL(KK).GE.CDIST) GOTO 140 483 : IREL=NTELCL(KK) 484 : IOB=(IREL-1)/NELEM 485 : IF (LISOUS(/1).NE.0) THEN 486 : IPT1=LISOUS(IOB) 487 : ELSE 488 : IPT1=MELEME 489 : ENDIF 490 : K=IREL-IOB*NELEM 491 : NBFAC=LTEL(1,IPT1.ITYPEL) 492 : IAD=LTEL(2,IPT1.ITYPEL)-1 493 : IDEDAF=0 494 : DO 116 IFAC=1,NBFAC 495 : ITYP=LDEL(1,IAD+IFAC) 496 : JAD=LDEL(2,IAD+IFAC)-1 497 : IDEP=KDFAC(2,ITYP) 498 : IFEP=IDEP+3*(KDFAC(3,ITYP)-1) 499 : IDEDAN=0 500 : DO 115 ITRIAN=IDEP,IFEP,3 501 : IA=ICPR(IPT1.NUM(LFAC(JAD+KFAC(ITRIAN)),K)) 502 : IB=ICPR(IPT1.NUM(LFAC(JAD+KFAC(ITRIAN+1)),K)) 503 : IC=ICPR(IPT1.NUM(LFAC(JAD+KFAC(ITRIAN+2)),K)) 504 : ZA=X(3,IA) 505 : ZB=X(3,IB) 506 : ZC=X(3,IC) 507 : IF (ZA.LT.CDIST) GOTO 201 508 : IF (ZB.LT.CDIST) GOTO 201 509 : IF (ZC.LT.CDIST) GOTO 201 510 : GOTO 123 511 : 201 IELD=1 512 : IF (IVU(IA).EQ.1) GOTO 200 513 : IF (IVU(IB).EQ.1) GOTO 200 514 : IF (IVU(IC).EQ.1) GOTO 200 515 : GOTO 123 516 : 200 IF (IA.EQ.IPVU) GOTO 202 517 : IF (IB.EQ.IPVU) GOTO 202 518 : IF (IC.EQ.IPVU) GOTO 202 519 : GOTO 203 520 : 202 IF (IA.EQ.IPCA) GOTO 123 521 : IF (IB.EQ.IPCA) GOTO 123 522 : IF (IC.EQ.IPCA) GOTO 123 523 : 203 CONTINUE 524 : VAX=COX-X(1,IA) 525 : VAY=COY-X(2,IA) 526 : VBX=COX-X(1,IB) 527 : VBY=COY-X(2,IB) 528 : VCX=COX-X(1,IC) 529 : VCY=COY-X(2,IC) 530 : DC=VAX*VBY-VAY*VBX 531 : DA=VBX*VCY-VBY*VCX 532 : IF (DA*DC.LT.0.) GOTO 123 533 : DB=VCX*VAY-VCY*VAX 534 : IF (DA*DB.LT.0.) GOTO 123 535 : IF (DC*DB.LT.0.) GOTO 123 536 : IF (ABS(DA).GT.SMO) GOTO 121 537 : IF (ABS(DB).GT.SMO) GOTO 121 538 : IF (ABS(DC).GT.SMO) GOTO 121 539 : IF (VAX*VBX.LT.-SMO) GOTO 123 540 : IF (VAX*VCX.LT.-SMO) GOTO 123 541 : IF (VAY*VCY.LT.-SMO) GOTO 123 542 : IF (VAY*VBY.LT.-SMO) GOTO 123 543 : IF (VBX*VCX.LT.-SMO) GOTO 123 544 : IF (VBY*VCY.LT.-SMO) GOTO 123 545 : 121 CONTINUE 546 : S=DA+DB+DC 547 : IF (S.EQ.0.) GOTO 123 548 : DA=DA/S 549 : DB=DB/S 550 : DC=DC/S 551 : S=DA*ZA+DB*ZB+DC*ZC 552 : IF (S.GT.CDIST) GOTO 123 553 : IDEDAN=IDEDAN+1 554 : 123 CONTINUE 555 : 115 CONTINUE 556 : idedaf = idedaf + mod(idedan,2) 557 : 116 CONTINUE 558 : IF (IDEDAf.ne.0) THEN 559 : C ON EST CACHE PAR L'ELEMENT K 560 : IF (IIMPI.NE.0) WRITE (IOIMP,9923) K 561 : 9923 FORMAT(' LIGNE CACHE PAR ',I6) 562 : IEL=K 563 : GOTO 150 564 : ENDIF 565 : 112 CONTINUE 566 : 140 CONTINUE 567 : C ON EST DESORMAIS VU. LE TRAIT S'ARRETE DONC LA 568 : 2601 CONTINUE 569 : XTR(1)=X(1,IPVU) 570 : YTR(1)=X(2,IPVU) 571 : XTR(2)=COX 572 : YTR(2)=COY 572 : CALL POLRL(2,XTR,YTR,ZTR) 573 : 100 CONTINUE 574 : 99 CONTINUE 575 : SEGSUP TRAV5,TRAV2,NTSEG,TRAV4 576 : IF (LISOUS(/1).EQ.0) GOTO 5001 577 : DO 5002 IOB=1,LISOUS(/1) 578 : IPT1=LISOUS(IOB) 579 : SEGDES IPT1 580 : 5002 CONTINUE 581 : 5001 CONTINUE 582 : SEGDES MELEME 583 : RETURN 584 : END 585 : 586 : 587 : 588 : 589 : 590 : 591 : 592 : 593 : 594 : 595 : 596 : 597 : 598 : 599 : 600 : 601 : 602 : 603 : 604 : 605 :
© Cast3M 2003 - All rights reserved.
Disclaimer