Télécharger dicho3.eso

Retour à la liste

Numérotation des lignes :

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

© Cast3M 2003 - Tous droits réservés.
Mentions légales