Télécharger j3coal.eso

Retour à la liste

Numérotation des lignes :

  1. C J3COAL SOURCE CHAT 05/01/13 00:46:02 5004
  2. SUBROUTINE J3COAL(WORK1,WORK2,LCAONB,VWORK,NFA,TOL,IRET)
  3. C----------------------------------------------------
  4. C COALESCENCE DES TROUS A ET B
  5. C
  6. C CODE IST(1,I): 0 point non traite
  7. C 1 est sur le segment IST(2,I)
  8. C 2 est sur les segments IST(2,I) et IST(3,I)
  9. C -1 est a l'interieur
  10. C -2 est a l'exterieur
  11. C
  12. C CODE CRO(J,I): 1 cote sur le segment
  13. C -1 cote interieur
  14. C -2 cote exterieur
  15. C
  16. C PP 6/97
  17. C Pierre Pegon/JRC Ispra
  18. C----------------------------------------------------
  19. IMPLICIT INTEGER(I-N)
  20. IMPLICIT REAL*8(A-H,O-Z)
  21. -INC CCOPTIO
  22. C
  23. SEGMENT WORK
  24. REAL*8 XYC(2,NPTO)
  25. INTEGER IST(3,NPTO)
  26. REAL*8 DENS(NPTO)
  27. INTEGER JUN
  28. ENDSEGMENT
  29. POINTEUR WORK1.WORK,WORK2.WORK,WORK3.WORK
  30. C
  31. SEGMENT WWORK
  32. REAL*8 PORIG(3),VNORM(3),VI(3),VJ(3)
  33. INTEGER FWORK
  34. INTEGER TWORK(NTROU)
  35. ENDSEGMENT
  36. C
  37. SEGMENT VWORK
  38. INTEGER FWWORK(NFACE)
  39. ENDSEGMENT
  40. C
  41. SEGMENT JUNC
  42. INTEGER CRO(2,NPTO)
  43. ENDSEGMENT
  44. C
  45. LOGICAL LCONTI,LAINB,LAOUB,LCAONB
  46. DIMENSION XY(2)
  47. C
  48. IF (IIMPI.EQ.1789)THEN
  49. WRITE(IOIMP,*)'>>> On entre dans j3coal <<<'
  50. ENDIF
  51. C
  52. VWORK=0
  53. NFA=0
  54. C
  55. C ON S'OCCUPE DU CAS DU CONTACT MULTI-PONCTUEL MAIS SANS COTE
  56. C COMMUN ENTRE A ET B. POUR CELA, ON "MERGE" A ET B AU NIVEAU
  57. C D'UN POINT COMMUN ET ON PASSE LE RESULTAT A LA MOULINETTE "14"
  58. C DES POINTS COMMUNS
  59. C
  60. IF(.NOT.LCAONB)THEN
  61. NPTO1=WORK1.XYC(/2)
  62. NPTO2=WORK2.XYC(/2)
  63. C
  64. IPTO=0
  65. NPTO=NPTO1+NPTO2
  66. SEGINI,WORK
  67. C
  68. DO IE1=1,NPTO1
  69. IPTO=IPTO+1
  70. DO IE2=1,2
  71. XYC(IE2,IPTO)=WORK1.XYC(IE2,IE1)
  72. ENDDO
  73. DENS(IPTO)=WORK1.DENS(IE1)
  74. IF(WORK1.IST(1,IE1).EQ.2)GOTO 100
  75. ENDDO
  76. C
  77. IRET=IRET+1
  78. WRITE(IOIMP,*)'J3COAL: ON NE TROUVE PAS DE POINT COMMUN'
  79. RETURN
  80. 100 CONTINUE
  81. I1=IE1
  82. C
  83. CALL J3NUMP(WORK1.IST(1,I1),NPTO2,I2)
  84. C
  85. DO IE1=1,NPTO2
  86. I2=I2+1
  87. IF(I2.GT.NPTO2)I2=I2-NPTO2
  88. IPTO=IPTO+1
  89. DO IE2=1,2
  90. XYC(IE2,IPTO)=WORK2.XYC(IE2,I2)
  91. ENDDO
  92. DENS(IPTO)=WORK2.DENS(I2)
  93. ENDDO
  94. C
  95. IF(I1.NE.NPTO1)THEN
  96. DO IE1=I1+1,NPTO1
  97. IPTO=IPTO+1
  98. DO IE2=1,2
  99. XYC(IE2,IPTO)=WORK1.XYC(IE2,IE1)
  100. ENDDO
  101. DENS(IPTO)=WORK1.DENS(IE1)
  102. ENDDO
  103. ENDIF
  104. C
  105. JUNC=WORK1.JUN
  106. IF(JUNC.NE.0)SEGSUP,JUNC
  107. SEGSUP,WORK1
  108. WORK1=WORK
  109. C
  110. GOTO 14
  111. C
  112. ENDIF
  113. C
  114. C ON COMPTE LE NOMBRE DE PLAGES OU A ET B ONT DES COTES COMMUNS
  115. C (ON FAIT UN RECOUVREMENT POUR ETRE SUR DU BON COMPTE: L'ALGO
  116. C SE PLANTE SI TOUS LES COTES SONT CONTIGUS, CE QUI EST IMPOSSIBLE)
  117. C
  118. I1=0
  119. LCONTI=.FALSE.
  120. NPTO1=WORK1.XYC(/2)
  121. JUNC=WORK1.JUN
  122. DO IE1=1,NPTO1
  123. ICRO=CRO(1,IE1)
  124. IF(ICRO.EQ.1)THEN
  125. IF(.NOT.LCONTI)THEN
  126. LCONTI=.TRUE.
  127. I1=I1+1
  128. ENDIF
  129. ELSE
  130. LCONTI=.FALSE.
  131. ENDIF
  132. ENDDO
  133. ICRO=CRO(2,NPTO1)
  134. IF(ICRO.EQ.1.AND.LCONTI)I1=I1-1
  135. C
  136. IF(I1.EQ.0)THEN
  137. IRET=IRET+1
  138. WRITE(IOIMP,*)'J3COAL: ON SE PLANTE SUR I1=0!'
  139. RETURN
  140. ENDIF
  141. NPTO2=WORK2.XYC(/2)
  142. IF(I1.EQ.1)GOTO 10
  143. C
  144. C ON PREPARE LA STRUCTURE DE DONNEE QUI RECEUILLERA LES NOUVELLES FACES
  145. C
  146. NFACE=I1-1
  147. SEGINI,VWORK
  148. C
  149. C S'IL Y A PLUSIEURS PLAGES, ON CHERCHE A LES REDUIRE A UNE
  150. C EN SUPPRIMANT LES TROUS
  151. C
  152. C A) On cree WORK3 qui contiendra a la fin le nouveau contour de A
  153. C
  154. NPTO=NPTO1+NPTO2
  155. IPTO3=0
  156. SEGINI,WORK3
  157. WORK3.JUN=0
  158. C
  159. C B) On boucle sur I1=nbtrou+1
  160. C
  161. IPLA1=1
  162. NTRO1=I1-1
  163. I0=I1
  164. DO IE0=1,I0
  165. C
  166. C C) On cherche la fin d'une plage
  167. C tout en recopiant les bords dans WORK3
  168. C
  169. DO IE1=IPLA1,NPTO1
  170. ICRO=CRO(1,IE1)
  171. ICRP=CRO(2,IE1)
  172. IF((ICRO-1)*(ICRP-1).EQ.0)THEN
  173. IPTO3=IPTO3+1
  174. DO IE2=1,2
  175. WORK3.XYC(IE2,IPTO3)=WORK1.XYC(IE2,IE1)
  176. ENDDO
  177. WORK3.DENS(IPTO3)=WORK1.DENS(IE1)
  178. ENDIF
  179. IF(ICRO.EQ.1.AND.ICRP.EQ.-2) GOTO 1
  180. ENDDO
  181. IRET=IRET+1
  182. WRITE(IOIMP,*)'J3COAL: ON NE TROUVE PAS UNE FIN DE PLAGE'
  183. RETURN
  184. 1 CONTINUE
  185. IPLA1=IE1
  186. C
  187. C D) On forme le candidat trou: on commence par le morceau sur A
  188. C
  189. NPTO=NPTO1+NPTO2
  190. IPTO=0
  191. SEGINI,WORK
  192. JUN=0
  193. DO IE1=1,NPTO1
  194. C
  195. I1=IE1+IPLA1-1
  196. IF(I1.GT.NPTO1)I1=I1-NPTO1
  197. C
  198. IPTO=IPTO+1
  199. DO IE2=1,2
  200. XYC(IE2,IPTO)=WORK1.XYC(IE2,I1)
  201. ENDDO
  202. DENS(IPTO)=WORK1.DENS(I1)
  203. C
  204. ICRO=CRO(1,I1)
  205. ICRP=CRO(2,I1)
  206. IF(ICRO.EQ.-2.AND.ICRP.EQ.1)GOTO 2
  207. C
  208. ENDDO
  209. IRET=IRET+1
  210. WRITE(IOIMP,*)'J3COAL: ON NE TROUVE PAS LA FIN D"UN TROU'
  211. RETURN
  212. 2 CONTINUE
  213. IPLB1=I1
  214. C
  215. C E) On continue par le morceau sur B jusqu'a refermeture
  216. C
  217. IF(WORK1.IST(1,IPLB1).NE.2)THEN
  218. IRET=IRET+1
  219. WRITE(IOIMP,*)'J3COAL: LA FIN DU TROU DE A DOIT SE TROUVER'
  220. WRITE(IOIMP,*)' SUR 2 COTES DE B'
  221. RETURN
  222. ENDIF
  223. C
  224. XX=XYC(1,1)
  225. YY=XYC(2,1)
  226. C
  227. CALL J3NUMP(WORK1.IST(1,I1),NPTO2,IPLA2)
  228. C
  229. DO IE1=1,NPTO2
  230. I1=IE1+IPLA2
  231. IF(I1.GT.NPTO2)I1=I1-NPTO2
  232. C
  233. DO IE2=1,2
  234. XY(IE2)=WORK2.XYC(IE2,I1)
  235. ENDDO
  236. C
  237. DIS=SQRT((XX-XY(1))**2+(YY-XY(2))**2)
  238. IF(DIS.LT.TOL)GOTO 3
  239. C
  240. IPTO=IPTO+1
  241. DO IE2=1,2
  242. XYC(IE2,IPTO)=XY(IE2)
  243. ENDDO
  244. DENS(IPTO)=WORK2.DENS(I1)
  245. C
  246. ENDDO
  247. IRET=IRET+1
  248. WRITE(IOIMP,*)'J3COAL: LE CANDIDAT TROU NE SE REFERME PAS'
  249. RETURN
  250. 3 CONTINUE
  251. NPTO=IPTO
  252. SEGADJ,WORK
  253. IPLB2=I1
  254. C
  255. C F) On verifie que le trou ne contient strictement aucun pt de A
  256. C et qu'il contient au moins un point exterieur
  257. C
  258. LAINB=.FALSE.
  259. LAOUB=.FALSE.
  260. DO IE1=1,NPTO1
  261. DO IE2=1,2
  262. XY(IE2)=WORK1.XYC(IE2,IE1)
  263. ENDDO
  264. CALL J3INEX(XY,XYC,NPTO,TOL,ICOD,ISIGM,IRET)
  265. IF(IRET.NE.0)RETURN
  266. IF(ICOD.EQ.-1)LAINB=.TRUE.
  267. IF(ICOD.EQ.-2)LAOUB=.TRUE.
  268. ENDDO
  269. C
  270. C G) Si le trou contient un point de A, ce n'est pas un trou...
  271. C et on recopie la suite de A
  272. C
  273. IF(LAINB)THEN
  274. IF(LAOUB)THEN
  275. IRET=IRET+1
  276. WRITE(IOIMP,*)'J3COAL: CE TROU ERRONE NE PEUT ETRE'
  277. WRITE(IOIMP,*) ' HORS DE A'
  278. RETURN
  279. ENDIF
  280. NPL1=IPLB1-IPLA1-1
  281. IF(NPL1.LT.0)NPL1=NPL1+NPTO1
  282. IF (NPL1.NE.0)THEN
  283. DO IE1=1,NPL1
  284. I1=IPLA1+IE1
  285. IF(I1.GT.NPTO1)I1=I1-NPTO1
  286. IPTO3=IPTO3+1
  287. DO IE2=1,2
  288. WORK3.XYC(IE2,IPTO3)=WORK1.XYC(IE2,I1)
  289. ENDDO
  290. WORK3.DENS(IPTO3)=WORK1.DENS(I1)
  291. ENDDO
  292. ENDIF
  293. C
  294. C G) Sinon on valide le trou ...
  295. C (son orientation type face devrait-etre OK)
  296. C
  297. ELSE
  298. IF(.NOT.LAOUB)THEN
  299. IRET=IRET+1
  300. WRITE(IOIMP,*)'J3COAL: LE NOUVEAU TROU NE PEUT CONTENIR A'
  301. RETURN
  302. ENDIF
  303. C
  304. NTRO1=NTRO1-1
  305. NTROU=0
  306. SEGINI,WWORK
  307. FWORK=WORK
  308. FWWORK(NFACE-NTRO1)=WWORK
  309. NFA=NFA+1
  310. C
  311. C H) ... et on change le contours de A (WORK3) (SEULEMENT
  312. C avec des points INTERIEURS a B parcouru a l'envers)
  313. C
  314. NPL2=IPLB2-IPLA2-1
  315. IF(NPL2.LT.0)NPL2=NPL2+NPTO2
  316. IF (NPL2.NE.0)THEN
  317. DO IE1=1,NPL2
  318. I1=IPLB2-IE1
  319. IF(I1.GT.NPTO2)I1=I1-NPTO2
  320. IPTO3=IPTO3+1
  321. DO IE2=1,2
  322. WORK3.XYC(IE2,IPTO3)=WORK2.XYC(IE2,I1)
  323. ENDDO
  324. WORK3.DENS(IPTO3)=WORK2.DENS(I1)
  325. ENDDO
  326. ENDIF
  327. ENDIF
  328. C
  329. C ?) Fin de boucle sur les trou
  330. C
  331. IPLA1=IPLB1
  332. IF(NTRO1.EQ.0)GOTO 4
  333. ENDDO
  334. IRET=IRET+1
  335. WRITE(IOIMP,*)'J3COAL: LE NOMBRE DE TROU EST INCONSISTENT'
  336. RETURN
  337. C
  338. C I) On termine A (WORK3) jusqu'a fermeture
  339. C
  340. 4 CONTINUE
  341. C
  342. XX=WORK3.XYC(1,1)
  343. YY=WORK3.XYC(2,1)
  344. DO IE1=1,NPTO1
  345. I1=IE1+IPLA1-1
  346. IF(I1.GT.NPTO1)I1=I1-NPTO1
  347. C
  348. DO IE2=1,2
  349. XY(IE2)=WORK1.XYC(IE2,I1)
  350. ENDDO
  351. C
  352. DIS=SQRT((XX-XY(1))**2+(YY-XY(2))**2)
  353. IF(DIS.LT.TOL)GOTO 5
  354. C
  355. IPTO3=IPTO3+1
  356. DO IE2=1,2
  357. WORK3.XYC(IE2,IPTO3)=XY(IE2)
  358. ENDDO
  359. WORK3.DENS(IPTO3)=WORK1.DENS(I1)
  360. C
  361. ENDDO
  362. C
  363. IRET=IRET+1
  364. WRITE(IOIMP,*)'J3COAL: ON N"ARRIVE PAS A REFERMER A'
  365. RETURN
  366. C
  367. C J) On ajuste A (WORK3) et on le re-compare a B
  368. C
  369. 5 CONTINUE
  370. NPTO=IPTO3
  371. SEGADJ,WORK3
  372. C
  373. CALL J3COTO(WORK3,WORK2,TOL,IRET)
  374. IF(IRET.NE.0)RETURN
  375. CALL J3JUNC(WORK3,WORK2,TOL,IRET)
  376. IF(IRET.NE.0)RETURN
  377. CALL J3JUNC(WORK2,WORK3,TOL,IRET)
  378. IF(IRET.NE.0)RETURN
  379. C
  380. C K) Si OK on substitue WORK3 a WORK1
  381. C
  382. JUNC=WORK1.JUN
  383. IF(JUNC.NE.0)SEGSUP,JUNC
  384. SEGSUP,WORK1
  385. WORK1=WORK3
  386. NPTO1=WORK1.XYC(/2)
  387. C ???
  388. NPTO2=WORK2.XYC(/2)
  389. C ???
  390. C
  391. C QUAND IL N'Y A PLUS QU'UNE SEULE PLAGE, ON COALESCE NORMALEMENT
  392. C
  393. 10 CONTINUE
  394. C
  395. NPTO=NPTO1+NPTO2
  396. IPTO3=0
  397. SEGINI,WORK3
  398. WORK3.JUN=0
  399. C
  400. C A) On recopie dans WORK3 les points de A exterieurs a B jusqu'au
  401. C debut de la plage de contact
  402. C
  403. JUNC=WORK1.JUN
  404. DO IE1=1,NPTO1
  405. ICRO=CRO(1,IE1)
  406. ICRP=CRO(2,IE1)
  407. IF(ICRO*ICRP.EQ.4)THEN
  408. IPTO3=IPTO3+1
  409. DO IE2=1,2
  410. WORK3.XYC(IE2,IPTO3)=WORK1.XYC(IE2,IE1)
  411. ENDDO
  412. WORK3.DENS(IPTO3)=WORK1.DENS(IE1)
  413. ENDIF
  414. IF(ICRO.EQ.-2.AND.ICRP.EQ.1)GOTO 11
  415. ENDDO
  416. IRET=IRET+1
  417. WRITE(IOIMP,*)'J3COAL: ON NE TROUVE PAS UN DEBUT DE PLAGE'
  418. RETURN
  419. C
  420. C B) On recopie les points de B jusqu'au debut de la plage (vue de B)
  421. C
  422. 11 CONTINUE
  423. IF(WORK1.IST(1,IE1).NE.2)THEN
  424. IRET=IRET+1
  425. WRITE(IOIMP,*)'J3COAL: QUAND ON PASSE SUR B LE POINT DOIT ETRE'
  426. WRITE(IOIMP,*)' SUR 2 COTES DE B'
  427. RETURN
  428. ENDIF
  429. C
  430. CALL J3NUMP(WORK1.IST(1,IE1),NPTO2,IPLA2)
  431. C
  432. JUNC=WORK2.JUN
  433. DO IE1=1,NPTO2
  434. I1=IE1+IPLA2-1
  435. IF(I1.GT.NPTO2)I1=I1-NPTO2
  436. C
  437. IPTO3=IPTO3+1
  438. DO IE2=1,2
  439. WORK3.XYC(IE2,IPTO3)=WORK2.XYC(IE2,I1)
  440. ENDDO
  441. WORK3.DENS(IPTO3)=WORK2.DENS(I1)
  442. C
  443. ICRO=CRO(1,I1)
  444. ICRP=CRO(2,I1)
  445. IF(ICRO.EQ.-2.AND.ICRP.EQ.1)GOTO 12
  446. C
  447. ENDDO
  448. IRET=IRET+1
  449. WRITE(IOIMP,*)'J3COAL: LA PARTIE B DE LA COALESCENCE NE RETOMBE'
  450. WRITE(IOIMP,*)' PAS SUR UNE PLAGE'
  451. RETURN
  452. C
  453. C C) On finit la boucle sur A
  454. C
  455. 12 CONTINUE
  456. IE1=I1
  457. IF(WORK2.IST(1,IE1).NE.2)THEN
  458. IRET=IRET+1
  459. WRITE(IOIMP,*)'J3COAL: QUAND ON PASSE SUR A LE POINT DOIT ETRE'
  460. WRITE(IOIMP,*)' SUR 2 COTES DE A'
  461. RETURN
  462. ENDIF
  463. C
  464. CALL J3NUMP(WORK2.IST(1,IE1),NPTO1,IPLA1)
  465. XX=WORK3.XYC(1,1)
  466. YY=WORK3.XYC(2,1)
  467. C
  468. DO IE1=1,NPTO1
  469. I1=IE1+IPLA1
  470. IF(I1.GT.NPTO1)I1=I1-NPTO1
  471. C
  472. DO IE2=1,2
  473. XY(IE2)=WORK1.XYC(IE2,I1)
  474. ENDDO
  475. C
  476. DIS=SQRT((XX-XY(1))**2+(YY-XY(2))**2)
  477. IF(DIS.LT.TOL)GOTO 13
  478. C
  479. IPTO3=IPTO3+1
  480. DO IE2=1,2
  481. WORK3.XYC(IE2,IPTO3)=XY(IE2)
  482. ENDDO
  483. WORK3.DENS(IPTO3)=WORK1.DENS(I1)
  484. C
  485. ENDDO
  486. C
  487. IRET=IRET+1
  488. WRITE(IOIMP,*)'J3COAL: ON N"ARRIVE PAS A REFERMER A'
  489. RETURN
  490. C
  491. C ON DIMENSIONNE CORRECTEMENT WORK3 QUE L'ON SUBSTITUE ENSUITE
  492. C A WORK1
  493. C
  494. 13 CONTINUE
  495. C
  496. NPTO=IPTO3
  497. SEGADJ,WORK3
  498. C
  499. JUNC=WORK1.JUN
  500. IF(JUNC.NE.0)SEGSUP,JUNC
  501. SEGSUP,WORK1
  502. WORK1=WORK3
  503. C
  504. C ENFIN ON VERIFIE QU'IL N'Y A PAS DES POINTS COMMUNS
  505. C
  506. 14 CONTINUE
  507. NPTO1=WORK1.XYC(/2)
  508. DO IE1=1,NPTO1
  509. WORK1.IST(1,IE1)=0
  510. ENDDO
  511. DO 21 IE1=1,NPTO1
  512. XX=WORK1.XYC(1,IE1)
  513. YY=WORK1.XYC(2,IE1)
  514. DO 20 IE2=1,NPTO1
  515. IF(IE2.EQ.IE1)GOTO 20
  516. DO IE3=1,2
  517. XY(IE3)=WORK1.XYC(IE3,IE2)
  518. ENDDO
  519. DIS=SQRT((XX-XY(1))**2+(YY-XY(2))**2)
  520. IF(DIS.LT.TOL)THEN
  521. WORK1.IST(1,IE1)=IE2
  522. GOTO 21
  523. ENDIF
  524. 20 CONTINUE
  525. 21 CONTINUE
  526. C
  527. I1=0
  528. DO IE1=1,NPTO1
  529. IF(WORK1.IST(1,IE1).NE.0)I1=I1+1
  530. ENDDO
  531. C
  532. C I1 DOIT ETRE UN MULTIPLE DE 2
  533. C
  534. IF(I1-(I1/2)*2.NE.0)THEN
  535. IRET=IRET+1
  536. WRITE(IOIMP,*)
  537. > 'J3COAL: LE NB DE PTS COMMUNS DOIT ETRE UN MULTIPLE DE 2'
  538. RETURN
  539. ENDIF
  540. I1=I1/2
  541. C
  542. C S'IL N'Y EN A PAS, ON PEUT SORTIR ...
  543. C
  544. IF(I1.EQ.0)RETURN
  545. C
  546. C SINON C'EST REPARTI POUR UN TOUR!
  547. C
  548. C A) On prepare la structure de donnes qui contiendra
  549. C les nouvelles faces
  550. C
  551. IF(LCAONB)THEN
  552. NTRO1=I1
  553. ELSE
  554. NTRO1=I1-1
  555. ENDIF
  556. IF(VWORK.EQ.0)THEN
  557. NFACE=NTRO1
  558. SEGINI,VWORK
  559. ELSE
  560. NFACE=FWWORK(/1)
  561. NFACE=NFACE+NTRO1
  562. SEGADJ,VWORK
  563. ENDIF
  564. WORK3=0
  565. C
  566. C B) On cherche les plages contigues entre les intersections
  567. C (il y en a NFACE+1) mais seules NFACE sont des trous
  568. C On attaque la boucle
  569. C
  570. IPLA1=1
  571. I0=NTRO1+1
  572. DO IE0=1,I0
  573. C
  574. C C) On localise le premier pont
  575. C
  576. DO IE1=IPLA1,NPTO1
  577. I1=WORK1.IST(1,IE1)
  578. IF(I1.NE.0)GOTO 30
  579. ENDDO
  580. IRET=IRET+1
  581. WRITE(IOIMP,*)
  582. > 'J3COAL: ON NE TROUVE PAS LE NB CORRECT DE CONTOURS'
  583. RETURN
  584. C
  585. C D) On prepare le nouveau contours
  586. C
  587. 30 CONTINUE
  588. NPTO=NPTO1
  589. IPTO=0
  590. SEGINI,WORK
  591. JUN=0
  592. C
  593. C E) On referme le contour sur le point de premier pont en
  594. C sautant eventuellement de pont en pont et en les coupant
  595. C au fur et a mesure
  596. C
  597. IPLA1=IE1
  598. WORK1.IST(1,IE1)=0
  599. C
  600. DO IE1=1,NPTO1
  601. C
  602. IPTO=IPTO+1
  603. DO IE2=1,2
  604. XYC(IE2,IPTO)=WORK1.XYC(IE2,I1)
  605. ENDDO
  606. DENS(IPTO)=WORK1.DENS(I1)
  607. C
  608. I1=I1+1
  609. IF(I1.GT.NPTO1)I1=I1-NPTO1
  610. IF(I1.EQ.IPLA1)GOTO 31
  611. C
  612. I2=WORK1.IST(1,I1)
  613. IF(I2.NE.0)THEN
  614. WORK1.IST(1,I1)=0
  615. I1=I2
  616. ENDIF
  617. IF(I1.EQ.IPLA1)GOTO 31
  618. ENDDO
  619. IRET=IRET+1
  620. WRITE(IOIMP,*)
  621. > 'J3COAL: ON NE TROUVE PAS LE NB CORRECT DE CONTOURS'
  622. RETURN
  623. C
  624. C F) On ajuste le contours
  625. C
  626. 31 CONTINUE
  627. NPTO=IPTO
  628. SEGADJ,WORK
  629. C
  630. C G) On verifie que le trou ne contient strictement aucun pt de A
  631. C et qu'il contient au moins un point exterieur
  632. C
  633. LAINB=.FALSE.
  634. LAOUB=.FALSE.
  635. NPTO=IPTO
  636. SEGADJ,WORK
  637. DO IE1=1,NPTO1
  638. DO IE2=1,2
  639. XY(IE2)=WORK1.XYC(IE2,IE1)
  640. ENDDO
  641. CALL J3INEX(XY,XYC,NPTO,TOL,ICOD,ISIGM,IRET)
  642. IF(IRET.NE.0)RETURN
  643. IF(ICOD.EQ.-1)LAINB=.TRUE.
  644. IF(ICOD.EQ.-2)LAOUB=.TRUE.
  645. ENDDO
  646. C
  647. C H) Si le trou contient un point de A, ce n'est pas un trou...
  648. C C'est en fait la silhouette de A (bien oriente!)
  649. C
  650. IF(LAINB)THEN
  651. IF(LAOUB)THEN
  652. IRET=IRET+1
  653. WRITE(IOIMP,*)'J3COAL: LA NOUVELLE SILHOUETTE NE PEUT ETRE'
  654. WRITE(IOIMP,*) ' HORS DE A'
  655. RETURN
  656. ENDIF
  657. WORK3=WORK
  658. C
  659. C I) Sinon on valide le trou ...
  660. C (son orientation type face devrait-etre OK)
  661. C
  662. ELSE
  663. IF(.NOT.LAOUB)THEN
  664. IRET=IRET+1
  665. WRITE(IOIMP,*)'J3COAL: LE NOUVEAU TROU NE PEUT CONTENIR A'
  666. RETURN
  667. ENDIF
  668. C
  669. NTRO1=NTRO1-1
  670. NTROU=0
  671. SEGINI,WWORK
  672. FWORK=WORK
  673. FWWORK(NFACE-NTRO1)=WWORK
  674. NFA=NFA+1
  675. C
  676. ENDIF
  677. C
  678. C J) On finit la boucle
  679. C
  680. ENDDO
  681. C
  682. C K) A ce point NTRO1 doit etre nul et WORK3 NE 0
  683. C
  684. IF((NTRO1.NE.0).OR.(WORK3.EQ.0))THEN
  685. IRET=IRET+1
  686. WRITE(IOIMP,*)'J3COAL: LE NOMBRE DE CONTOURS EST INCONSISTENT'
  687. RETURN
  688. ENDIF
  689. C
  690. C L) WORK3 "nouveau A" vient substituer A
  691. C
  692. JUNC=WORK1.JUN
  693. IF(JUNC.NE.0)SEGSUP,JUNC
  694. SEGSUP,WORK1
  695. WORK1=WORK3
  696. C
  697. RETURN
  698. END
  699.  
  700.  
  701.  

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