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

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