Télécharger j3sure.eso

Retour à la liste

Numérotation des lignes :

  1. C J3SURE SOURCE CHAT 05/01/13 00:47:25 5004
  2. SUBROUTINE J3SURE(VWORK1,IRET,TOL)
  3. C----------------------------------------------------
  4. C ELIMINATION DES CAS TORDUS POUR SURF
  5. C QUI CREE DE NOUVELLE FACES:
  6. C
  7. C - CYCLE INTERIEUR DE TROU
  8. C - CYCLE DE TROU AVEC LE CONTOUR PRINCIPAL
  9. C
  10. C PP 12/98
  11. C Pierre Pegon/JRC Ispra
  12. C----------------------------------------------------
  13. IMPLICIT INTEGER(I-N)
  14. IMPLICIT REAL*8(A-H,O-Z)
  15. DIMENSION XY(2)
  16. C
  17. -INC CCOPTIO
  18. C
  19. SEGMENT VWORK
  20. INTEGER FWWORK(NFACE)
  21. ENDSEGMENT
  22. POINTEUR VWORK1.VWORK,VWORK2.VWORK,VWDUMM.VWORK
  23. C
  24. SEGMENT WWORK
  25. REAL*8 PORIG(3),VNORM(3),VI(3),VJ(3)
  26. INTEGER FWORK
  27. INTEGER TWORK(NTROU)
  28. ENDSEGMENT
  29. POINTEUR WWORK1.WWORK
  30. C
  31. SEGMENT WORK
  32. REAL*8 XYC(2,NPTO)
  33. INTEGER IST(3,NPTO)
  34. REAL*8 DENS(NPTO)
  35. INTEGER JUN
  36. ENDSEGMENT
  37. POINTEUR WORK1.WORK,WORK2.WORK,WORK3.WORK
  38. C
  39. SEGMENT JUNC
  40. INTEGER CRO(2,NPTO)
  41. ENDSEGMENT
  42. C
  43. SEGMENT WCYCL
  44. C CONNEC(.,.,J)=NO DU CONTOUR CONCERNE
  45. C CONNEC(.,I,J)=IEME VOISIN DU TROU J
  46. C CONNEC(1,.,.)=NO DU POINT
  47. C CONNEC(2,.,.)=NO DU CONTOUR EN CONTACT
  48. C CONNEC(1,.,.)=NO DU POINT
  49. INTEGER CONNEC(3,NTROV,NTROV)
  50. C NCONNE(J)=NB DE VOISIN DU TROU J
  51. INTEGER NCONNE(NTROV)
  52. C NCYCLE(.,I)=NIVEAU DANS LE CYCLE DE TROU
  53. C NCYCLE(1,,)=TROU AMONT
  54. C NCYCLE(2,,)=TROU COURANT
  55. C NCYCLE(3,,)=RANG DU VOISIN COURANT
  56. INTEGER NCYCLE(3,NTROV)
  57. INTEGER NINDEX(NTROV)
  58. ENDSEGMENT
  59. C
  60. C ON RENTRE AVEC DES ENSEMBLE DE VWORK REPRESENTANT CHACUN
  61. C UN BLOCK COMPOSE DE FACE
  62. C
  63. NBLOCK=VWORK1.FWWORK(/1)
  64. C
  65. C ON BOUCLE SUR CHAQUE BLOCK
  66. C
  67. DO IE1=1,NBLOCK
  68. VWORK=VWORK1.FWWORK(IE1)
  69. NFACF=FWWORK(/1)
  70. C
  71. C ON BOUCLE SUR CHAQUE FACE (ON SIMULE DO 1000 IE2=1,NFACE
  72. C
  73. C DO 1000 IE2=1,NFACE
  74. C
  75. IE2=0
  76. 1000 IE2=IE2+1
  77. IF (IE2.GT.NFACF)GOTO 1001
  78. C
  79. WWORK=FWWORK(IE2)
  80. NTROU=TWORK(/1)
  81. C
  82. C S'IL Y A MOINS DE 2 TROUS, IL N'Y A PAS POSSIBILITE DE CYCLE INTE
  83. C OU EXTE ET ALORS ON NE FAIT RIEN
  84. C EN FAIT J3SURE LUI MEME PEUT CREER DES FACES AVEC UN TROU... QUI
  85. C SONT CANDIDAT A LA COUPE...
  86. C
  87. C IF(NTROU.LT.2)GOTO 1000
  88. IF(NTROU.EQ.0)GOTO 1000
  89. C
  90. C ON CHERCHE QUI EST EN CONTACT (PONCTUEL) AVEC QUOI
  91. C ON CHERCHE MEME AU DELA DE 1 PT [CAR LA COALESCENCE DE TROUS EN
  92. C CONTACT AVEC UN SEUL POINT PEUT CREER DU CONTACT MULTI POINT!)
  93. C
  94. NTROV=NTROU+1
  95. SEGINI,WCYCL
  96. DO JE1=1,NTROU
  97. NCONNE(JE1)=0
  98. ENDDO
  99. C
  100. C WARNING: S'IL N'Y A QU'UN SEUL TROU... ON REGARDE DIRECTEMENT
  101. C LES POSSIBILITES DE COUPE
  102. C
  103. IF(NTROU.EQ.1)GOTO 100
  104. C
  105. DO JE1=1,NTROU-1
  106. WORK1=TWORK(JE1)
  107. NPTO1=WORK1.XYC(/2)
  108. DO JE2=JE1+1,NTROU
  109. WORK2=TWORK(JE2)
  110. NPTO2=WORK2.XYC(/2)
  111. DO JE3=1,NPTO1
  112. XX=WORK1.XYC(1,JE3)
  113. YY=WORK1.XYC(2,JE3)
  114. DO JE4=1,NPTO2
  115. DO JE5=1,2
  116. XY(JE5)=WORK2.XYC(JE5,JE4)
  117. ENDDO
  118. DIS=SQRT((XX-XY(1))**2+(YY-XY(2))**2)
  119. IF(DIS.LT.TOL)THEN
  120. C
  121. C WARNING ON TESTE ICI LA POSSIBILITE DE CONTACT MULTI PONCTUEL QUE L'ON
  122. C TRAITERA PAR COHALESCENCE
  123. C
  124. IF(NCONNE(JE1).GT.0)THEN
  125. DO JE6=1,NCONNE(JE1)
  126. IF(CONNEC(2,JE6,JE1).EQ.JE2)GOTO 300
  127. ENDDO
  128. ENDIF
  129. C
  130. NCONNE(JE1)=NCONNE(JE1)+1
  131. CONNEC(1,NCONNE(JE1),JE1)=JE3
  132. CONNEC(2,NCONNE(JE1),JE1)=JE2
  133. CONNEC(3,NCONNE(JE1),JE1)=JE4
  134. NCONNE(JE2)=NCONNE(JE2)+1
  135. CONNEC(1,NCONNE(JE2),JE2)=JE4
  136. CONNEC(2,NCONNE(JE2),JE2)=JE1
  137. CONNEC(3,NCONNE(JE2),JE2)=JE3
  138. ENDIF
  139. ENDDO
  140. ENDDO
  141. ENDDO
  142. ENDDO
  143. C
  144. C SI IL N'Y A QUE 2 TROUS, ON SAUTE DIRECTEMENT AUX CYCLES EXTERNES
  145. C
  146. IF(NTROU.EQ.2)GOTO 100
  147. C
  148. C ON REGARDE LE NB DE TROU EN CONTACT AVEC AU MOINS 2 AUTRES
  149. C
  150. ICONT2=0
  151. DO JE1=1,NTROU
  152. IF(NCONNE(JE1).GE.2)THEN
  153. ICONT2=ICONT2+1
  154. NINDEX(ICONT2)=JE1
  155. ENDIF
  156. ENDDO
  157. C
  158. C SI CE NB EST PLUS PETIT QUE 3, ALORS ON PASSE AUX CYCLES EXTERNES
  159. C
  160. IF(ICONT2.LT.3)GOTO 100
  161. C
  162. C SINON ON FORME LES CYCLES EN DONNANT COMME RACINE, SUCCESSIVEMENT,
  163. C LES ICONT2-2 PREMIERS TROUS AYANT 2 VOISINS
  164. C
  165. DO 3 IE3=1,ICONT2-2
  166. C
  167. C ON CHERCHE A FORMER LES CYCLES A PARTIR DES VOISINS DU PREMIER
  168. C TROU
  169. C
  170. ITROU=1
  171. NCYCLE(1,ITROU)=0
  172. NCYCLE(2,ITROU)=NINDEX(IE3)
  173. NCYCLE(3,ITROU)=0
  174. 2 CONTINUE
  175. C
  176. C 1) ON A TOUT INSPECTE SANS RIEN TROUVE (RETOUR AU NIVEAU 0)
  177. C ---> ON PASSE A LA RACINE SUIVANTE
  178. C
  179. IF(ITROU.EQ.0)THEN
  180. GOTO 3
  181. ENDIF
  182. C
  183. C 2) ON PASSE AU VOISIN SUIVANT DU TROU DU NIVEAU COURANT
  184. C SI IL N'Y EN A PAS ON RETOURNE AU NIVEAU PRECEDENT
  185. C
  186. NCYCLE(3,ITROU)=NCYCLE(3,ITROU)+1
  187. IF(NCYCLE(3,ITROU).GT.NCONNE(NCYCLE(2,ITROU)))THEN
  188. ITROU=ITROU-1
  189. GOTO 2
  190. ENDIF
  191. C
  192. C 3) ON RECUPERE LE NUMERO DU VOISIN
  193. C SI LE VOISIN EST EGAL AU TROU PARENT ON PASSE
  194. C SI LE VOISIN A MOINS DE 2 VOISINS ON PASSE
  195. C SI LE VOISIN EST LE TROU NO.1 ON A IDENTIFIE LE CYCLE
  196. C SINON, LE VOISIN DEVIENT LE TROU DE NIVEAU SUIVANT ET ON CONTINUE
  197. C
  198. IVOIS=CONNEC(2,NCYCLE(3,ITROU),NCYCLE(2,ITROU))
  199. IF(IVOIS.EQ.NCYCLE(1,ITROU))GOTO 2
  200. IF(NCONNE(IVOIS).LT.2)GOTO 2
  201. C
  202. C WARNING: SI ON A FINI LA BOUCLE, IL FAUT LA VALIDER... C.A.D. QU'IL FAUT
  203. C QU'IL Y EST AU MOINS 3 TROUS NON PARASITES...
  204. C
  205. C IF(IVOIS.EQ.NINDEX(IE3))GOTO 31
  206. IF(IVOIS.EQ.NINDEX(IE3))THEN
  207. NCYCLE(1,1)=NCYCLE(2,ITROU)
  208. IITROU=0
  209. DO JE1=1,ITROU
  210. IPAREN=NCYCLE(1,JE1)
  211. ICOURA=NCYCLE(2,JE1)
  212. IF(JE1.EQ.ITROU)THEN
  213. IENFAN=NINDEX(IE3)
  214. ELSE
  215. IENFAN=NCYCLE(2,JE1+1)
  216. ENDIF
  217. IPSTAR=0
  218. IPFIN=0
  219. DO JE2=1,NCONNE(ICOURA)
  220. IF(CONNEC(2,JE2,ICOURA).EQ.IPAREN)
  221. 1 IPSTAR=CONNEC(1,JE2,ICOURA)
  222. IF(CONNEC(2,JE2,ICOURA).EQ.IENFAN)
  223. 1 IPFIN=CONNEC(1,JE2,ICOURA)
  224. ENDDO
  225. IF(IPSTAR.EQ.IPFIN)THEN
  226. NCYCLE(2,JE1)=-NCYCLE(2,JE1)
  227. ELSE
  228. IITROU=IITROU+1
  229. ENDIF
  230. ENDDO
  231. IF(IITROU.GE.3)THEN
  232. GOTO 31
  233. ELSE
  234. DO JE1=1,ITROU
  235. NCYCLE(2,JE1)=ABS(NCYCLE(2,JE1))
  236. ENDDO
  237. GOTO 2
  238. ENDIF
  239. ENDIF
  240. C
  241. C FIN VALIDATION
  242. C
  243. ITROU=ITROU+1
  244. NCYCLE(1,ITROU)=NCYCLE(2,ITROU-1)
  245. NCYCLE(2,ITROU)=IVOIS
  246. NCYCLE(3,ITROU)=0
  247. GOTO 2
  248. C
  249. 3 CONTINUE
  250. C
  251. C SI ON EST LA, C'EST QU'IL N'Y A PAS DE CYCLE INTERNE ET ON PASSE
  252. C AUX CYCLES EXTERNES
  253. C
  254. GOTO 100
  255. C
  256. C C'EST LA QUE L'ON SORT EN CAS DE CYCLE EN COMPLETANT NCYCLE(1,1)...
  257. C
  258. C31 NCYCLE(1,1)=NCYCLE(2,ITROU)
  259. 31 CONTINUE
  260. C
  261. C CREATION DU NOUVEAU TROU ET DE LA NOUVELLE FACE
  262. C
  263. C 1) CREATION DU COUNTOUR
  264. C
  265. NPTO=0
  266. SEGINI,WORK
  267. C
  268. C 2) BOUCLE SUR LES TROU DANS UN SENS
  269. C
  270. DO 4 JE1=1,ITROU
  271. C
  272. C 3) LOCALISATION DES TROUS VOISINS ET DES PT DE CONTACTS
  273. C
  274. IPAREN=NCYCLE(1,JE1)
  275. ICOURA=NCYCLE(2,JE1)
  276. IF(ICOURA.LT.0)GOTO 4
  277. IF(JE1.EQ.ITROU)THEN
  278. IENFAN=NINDEX(IE3)
  279. ELSE
  280. IENFAN=ABS(NCYCLE(2,JE1+1))
  281. ENDIF
  282. IPSTAR=0
  283. IPFIN=0
  284. DO JE2=1,NCONNE(ICOURA)
  285. IF(CONNEC(2,JE2,ICOURA).EQ.IPAREN)
  286. 1 IPSTAR=CONNEC(1,JE2,ICOURA)
  287. IF(CONNEC(2,JE2,ICOURA).EQ.IENFAN)
  288. 1 IPFIN =CONNEC(1,JE2,ICOURA)
  289. ENDDO
  290. IF(IPSTAR*IPFIN.EQ.0)THEN
  291. IRAISO=1
  292. SEGSUP,WORK
  293. GOTO 9999
  294. ENDIF
  295. C
  296. C 4) ON ELIMINE LE CAS D'UN TROU PARASITE EN CONTACT PONCTUEL AU PT DE
  297. C CONTACT ENTRE 2 "VRAIS" VOISINS
  298. C
  299. C IF(IPSTAR.EQ.IPFIN)THEN
  300. C NCYCLE(2,JE1)=-NCYCLE(2,JE1)
  301. C GOTO 4
  302. C ENDIF
  303. C
  304. C 5) ON AJOUTE LES POINTS (EN PARTANT DE LA FIN)
  305. C
  306. WORK1=TWORK(ICOURA)
  307. NPTO1=WORK1.XYC(/2)
  308. NPTO2=IPFIN-IPSTAR
  309. IF(NPTO2.LT.0)NPTO2=NPTO2+NPTO1
  310. NPTO=NPTO+NPTO2
  311. SEGADJ,WORK
  312. IPCOUR=IPFIN
  313. DO JE2=1,NPTO2
  314. IPCOUR=IPCOUR-1+(1/IPCOUR)*NPTO1
  315. XYC(1,NPTO-JE2+1)=WORK1.XYC(1,IPCOUR)
  316. XYC(2,NPTO-JE2+1)=WORK1.XYC(2,IPCOUR)
  317. DENS(NPTO-JE2+1)=WORK1.DENS(IPCOUR)
  318. ENDDO
  319. 4 CONTINUE
  320. C
  321. C 6) NOUVEAU CONTOUR DANS WORK3
  322. C
  323. WORK3=WORK
  324. C
  325. C 7) CREATION DU CONTOUR
  326. C
  327. NPTO=0
  328. SEGINI,WORK
  329. C
  330. C 8) BOUCLE SUR LES TROU DANS L'AUTRE SENS
  331. C
  332. DO 5 JE1=ITROU,1,-1
  333. C
  334. C 9) LOCALISATION DES TROUS VOISINS ET DES PT DE CONTACTS
  335. C (ON ECHANGE LE ROLE DE IPFIN ET IPSTAR)
  336. C
  337. IPAREN=NCYCLE(1,JE1)
  338. ICOURA=NCYCLE(2,JE1)
  339. IF(ICOURA.LT.0)GOTO 5
  340. IF(JE1.EQ.ITROU)THEN
  341. IENFAN=NINDEX(IE3)
  342. ELSE
  343. IENFAN=ABS(NCYCLE(2,JE1+1))
  344. ENDIF
  345. IPSTAR=0
  346. IPFIN=0
  347. DO JE2=1,NCONNE(ICOURA)
  348. IF(CONNEC(2,JE2,ICOURA).EQ.IPAREN)
  349. 1 IPFIN=CONNEC(1,JE2,ICOURA)
  350. IF(CONNEC(2,JE2,ICOURA).EQ.IENFAN)
  351. 1 IPSTAR=CONNEC(1,JE2,ICOURA)
  352. ENDDO
  353. IF(IPSTAR*IPFIN.EQ.0)THEN
  354. IRAISO=2
  355. SEGSUP,WORK,WORK3
  356. GOTO 9999
  357. ENDIF
  358. C
  359. C 10) ON AJOUTE LES POINTS (EN PARTANT DE LA FIN)
  360. C
  361. WORK1=TWORK(ICOURA)
  362. NPTO1=WORK1.XYC(/2)
  363. NPTO2=IPFIN-IPSTAR
  364. IF(NPTO2.LT.0)NPTO2=NPTO2+NPTO1
  365. NPTO=NPTO+NPTO2
  366. SEGADJ,WORK
  367. IPCOUR=IPFIN
  368. DO JE2=1,NPTO2
  369. IPCOUR=IPCOUR-1+(1/IPCOUR)*NPTO1
  370. XYC(1,NPTO-JE2+1)=WORK1.XYC(1,IPCOUR)
  371. XYC(2,NPTO-JE2+1)=WORK1.XYC(2,IPCOUR)
  372. DENS(NPTO-JE2+1)=WORK1.DENS(IPCOUR)
  373. ENDDO
  374. 5 CONTINUE
  375. C
  376. C 11) NOUVEAU CONTOUR DANS WORK2
  377. C
  378. WORK2=WORK
  379. C
  380. C 12) ON REGARDE L'ORIENTATION DE WORK2 ET WORK3
  381. C WORK2 SERA LE TROU ET WORK3 LA NOUVELLE FACE
  382. C
  383. NPTO2=WORK2.XYC(/2)
  384. CALL J3ORIE(0,WORK2.XYC,WORK2.DENS,NPTO2,IORI2,TOL,IRET)
  385. IF(IRET.NE.0)THEN
  386. IRAISO=3
  387. SEGSUP,WORK2,WORK3
  388. GOTO 9999
  389. ENDIF
  390. NPTO3=WORK3.XYC(/2)
  391. CALL J3ORIE(0,WORK3.XYC,WORK3.DENS,NPTO3,IORI3,TOL,IRET)
  392. IF(IRET.NE.0)THEN
  393. IRAISO=4
  394. SEGSUP,WORK2,WORK3
  395. GOTO 9999
  396. ENDIF
  397. IF(IORI2*IORI3.EQ.1)THEN
  398. IRAISO=5
  399. SEGSUP,WORK2,WORK3
  400. GOTO 9999
  401. ENDIF
  402. IF(IORI2.EQ.1)THEN
  403. WORK=WORK3
  404. WORK3=WORK2
  405. WORK2=WORK
  406. ENDIF
  407. C
  408. C 13) ON AJUSTE LES TROUS (ON SUPRIME CEUX QUI ONT EFFECTIVEMENT
  409. C COALESCE
  410. C
  411. WORK=TWORK(NINDEX(IE3))
  412. SEGSUP,WORK
  413. TWORK(NINDEX(IE3))=WORK2
  414. DO JE1=2,ITROU
  415. ICOURA=NCYCLE(2,JE1)
  416. IF(ICOURA.GT.0)THEN
  417. WORK=TWORK(ICOURA)
  418. IF(WORK.NE.0)THEN
  419. SEGSUP,WORK
  420. TWORK(ICOURA)=0
  421. ENDIF
  422. ENDIF
  423. ENDDO
  424. C
  425. C 14) ET LA NOUVELLE FACE (A VOIR LE FORMAT)
  426. C
  427. NFACE=1
  428. SEGINI,VWORK2
  429. NTROU=0
  430. SEGINI,WWORK1
  431. WWORK1.FWORK=WORK3
  432. VWORK2.FWWORK(1)=WWORK1
  433. C CALL J3MUFA(VWORK2,TOL,IRET)
  434. C
  435. C 15) TRANSFERT DES TROUS DE LA FACE COURANTE DANS LA NOUVELLE
  436. C QUE L'ON AJOUTE AU BLOCK COURRANT
  437. C
  438. CALL J3HEAD(WWORK,VWORK2)
  439. CALL J3COAK(WWORK,VWORK2,TOL,IRET)
  440. IF(IRET.NE.0)THEN
  441. IRAISO=4
  442. SEGSUP,WORK2,WORK3,VWORK2,WWORK1
  443. GOTO 9999
  444. ENDIF
  445. NFACE=NFACF+1
  446. SEGADJ,VWORK
  447. FWWORK(NFACE)=VWORK2.FWWORK(1)
  448. C
  449. C 16) ON AJUSTE LA FACE COURRANTE
  450. C
  451. CALL J3REDU(WWORK)
  452. C
  453. C ON FAIT LE MENAGE ET ON RERENTRE DANS LA BOUCLE JE2
  454. C
  455. SEGSUP,WCYCL,VWORK2
  456. IE2=IE2-1
  457. NFACF=NFACE
  458. GOTO 1000
  459. C
  460. C DEBUT DE CYCLE EXTERNE
  461. C
  462. 100 CONTINUE
  463. C
  464. C ON COMPLETE QUI TOUCHE QUOI AVEC LA DERNIERE FACE: LE CONTOUR EXTE
  465. C ICI, ON CHERCHE AU DELA DE 1 PT CAR UN TROU FORME PAR COHALESCENCE
  466. C CYCLIQUE PEUT PRESENTE CETTE PATHOLOGIE
  467. C
  468. NCONNE(NTROV)=0
  469. WORK1=FWORK
  470. NPTO1=WORK1.XYC(/2)
  471. DO JE2=1,NTROU
  472. WORK2=TWORK(JE2)
  473. NPTO2=WORK2.XYC(/2)
  474. DO JE3=1,NPTO1
  475. XX=WORK1.XYC(1,JE3)
  476. YY=WORK1.XYC(2,JE3)
  477. DO JE4=1,NPTO2
  478. DO JE5=1,2
  479. XY(JE5)=WORK2.XYC(JE5,JE4)
  480. ENDDO
  481. DIS=SQRT((XX-XY(1))**2+(YY-XY(2))**2)
  482. IF(DIS.LT.TOL)THEN
  483. NCONNE(NTROV)=NCONNE(NTROV)+1
  484. CONNEC(1,NCONNE(NTROV),NTROV)=JE3
  485. CONNEC(2,NCONNE(NTROV),NTROV)=JE2
  486. CONNEC(3,NCONNE(NTROV),NTROV)=JE4
  487. NCONNE(JE2)=NCONNE(JE2)+1
  488. CONNEC(1,NCONNE(JE2),JE2)=JE4
  489. CONNEC(2,NCONNE(JE2),JE2)=NTROV
  490. CONNEC(3,NCONNE(JE2),JE2)=JE3
  491. ENDIF
  492. ENDDO
  493. ENDDO
  494. ENDDO
  495. C
  496. C SI LE CONTOUR EXTE N'EST PAS EN CONTACT AVEC AU MOINS 2 TROUS ALORS ON PASSE
  497. C
  498. IF(NCONNE(NTROV).LT.2)THEN
  499. SEGSUP,WCYCL
  500. GOTO 1000
  501. ENDIF
  502. C
  503. C SI L'UN DES TROUS EST EN BI-CONTACT AVEC LE CONTOUR EXTE, ON SAUTE
  504. C DIRECTEMENT A LA COUPE SANS FORMER D'ARBRE
  505. C
  506. DO JE1=1,NTROU
  507. NVOIS1=0
  508. IF(NCONNE(JE1).GT.0)THEN
  509. DO JE2=1,NCONNE(JE1)
  510. IF(CONNEC(2,JE2,JE1).EQ.NTROV)NVOIS1=NVOIS1+1
  511. ENDDO
  512. ENDIF
  513. IF(NVOIS1.GE.2)THEN
  514. WORK2=TWORK(JE1)
  515. TWORK(JE1)=0
  516. GOTO 200
  517. ENDIF
  518. ENDDO
  519. C
  520. C RECHERCHE DE CYCLE AVEC LE CONTOUR EXTERIEUR COMME RACINE
  521. C
  522. ITROU=1
  523. NCYCLE(1,ITROU)=0
  524. NCYCLE(2,ITROU)=NTROV
  525. NCYCLE(3,ITROU)=0
  526. 102 CONTINUE
  527. C
  528. C 1) ON A TOUT INSPECTE SANS RIEN TROUVE (RETOUR AU NIVEAU 0)
  529. C ---> ON PASSE A LA FACE SUIVANTE
  530. C
  531. IF(ITROU.EQ.0)THEN
  532. SEGSUP,WCYCL
  533. GOTO 1000
  534. ENDIF
  535. C
  536. C 2) ON PASSE AU VOISIN SUIVANT DU TROU DU NIVEAU COURANT
  537. C SI IL N'Y EN A PAS ON RETOURNE AU NIVEAU PRECEDENT
  538. C
  539. NCYCLE(3,ITROU)=NCYCLE(3,ITROU)+1
  540. IF(NCYCLE(3,ITROU).GT.NCONNE(NCYCLE(2,ITROU)))THEN
  541. ITROU=ITROU-1
  542. GOTO 102
  543. ENDIF
  544. C
  545. C 3) ON RECUPERE LE NUMERO DU VOISIN
  546. C SI LE VOISIN EST EGAL AU TROU PARENT ON PASSE
  547. C SI LE VOISIN A MOINS DE 2 VOISINS ON PASSE
  548. C SI LE VOISIN EST LE TROU NO.1 ON A IDENTIFIE LE CYCLE
  549. C SINON, LE VOISIN DEVIENT LE TROU DE NIVEAU SUIVANT ET ON CONTINUE
  550. C
  551. IVOIS=CONNEC(2,NCYCLE(3,ITROU),NCYCLE(2,ITROU))
  552. IF(IVOIS.EQ.NCYCLE(1,ITROU))GOTO 102
  553. IF(NCONNE(IVOIS).LT.2)GOTO 102
  554.  
  555. C
  556. C WARNING: SI ON A FINI LA BOUCLE, IL FAUT LA VALIDER... C.A.D. QU'IL FAUT
  557. C QU'IL Y EST AU MOINS 3 TROUS NON PARASITES...
  558. C
  559. C IF(IVOIS.EQ.NTROV)GOTO 104
  560. IF(IVOIS.EQ.NTROV)THEN
  561. NCYCLE(1,1)=NCYCLE(2,ITROU)
  562. IITROU=0
  563. DO JE1=1,ITROU
  564. IPAREN=NCYCLE(1,JE1)
  565. ICOURA=NCYCLE(2,JE1)
  566. IF(JE1.EQ.ITROU)THEN
  567. IENFAN=NINDEX(IE3)
  568. ELSE
  569. IENFAN=NCYCLE(2,JE1+1)
  570. ENDIF
  571. IPSTAR=0
  572. IPFIN=0
  573. DO JE2=1,NCONNE(ICOURA)
  574. IF(CONNEC(2,JE2,ICOURA).EQ.IPAREN)
  575. 1 IPSTAR=CONNEC(1,JE2,ICOURA)
  576. IF(CONNEC(2,JE2,ICOURA).EQ.IENFAN)
  577. 1 IPFIN=CONNEC(1,JE2,ICOURA)
  578. ENDDO
  579. IF(IPSTAR.EQ.IPFIN)THEN
  580. NCYCLE(2,JE1)=-NCYCLE(2,JE1)
  581. ELSE
  582. IITROU=IITROU+1
  583. ENDIF
  584. ENDDO
  585. IF(IITROU.GE.3)THEN
  586. GOTO 104
  587. ELSE
  588. DO JE1=1,ITROU
  589. NCYCLE(2,JE1)=ABS(NCYCLE(2,JE1))
  590. ENDDO
  591. GOTO 102
  592. ENDIF
  593. ENDIF
  594. C
  595. C FIN VALIDATION
  596. C
  597. ITROU=ITROU+1
  598. NCYCLE(1,ITROU)=NCYCLE(2,ITROU-1)
  599. NCYCLE(2,ITROU)=IVOIS
  600. NCYCLE(3,ITROU)=0
  601. GOTO 102
  602. C
  603. C C'EST LA QUE L'ON SORT EN CAS DE CYCLE EN COMPLETANT NCYCLE(1,1)...
  604. C
  605. C104 NCYCLE(1,1)=NCYCLE(2,ITROU)
  606. 104 CONTINUE
  607. C
  608. C COHALESCENCE PAR LA POINTE DES TROUS QUI FORMENT LE CYCLE
  609. C
  610. C
  611. C 1) CREATION DU CONTOUR
  612. C
  613. NPTO=0
  614. SEGINI,WORK
  615. C
  616. C 2) BOUCLE SUR LES TROU DANS UN SENS
  617. C
  618. DO 105 JE1=2,ITROU
  619. C
  620. C 3) LOCALISATION DES TROUS VOISINS ET DES PT DE CONTACTS
  621. C
  622. IPAREN=NCYCLE(1,JE1)
  623. ICOURA=NCYCLE(2,JE1)
  624. IF(ICOURA.LT.0)GOTO 105
  625. IF(JE1.EQ.ITROU)THEN
  626. IENFAN=NTROV
  627. ELSE
  628. IENFAN=ABS(NCYCLE(2,JE1+1))
  629. ENDIF
  630. IPSTAR=0
  631. IPFIN=0
  632. DO JE2=1,NCONNE(ICOURA)
  633. IF(CONNEC(2,JE2,ICOURA).EQ.IPAREN)
  634. 1 IPSTAR=CONNEC(1,JE2,ICOURA)
  635. IF(CONNEC(2,JE2,ICOURA).EQ.IENFAN)
  636. 1 IPFIN=CONNEC(1,JE2,ICOURA)
  637. ENDDO
  638. IF(IPSTAR*IPFIN.EQ.0)THEN
  639. IRAISO=10
  640. SEGSUP,WORK
  641. GOTO 9999
  642. ENDIF
  643. C
  644. C 4) ON ELIMINE LE CAS D'UN TROU PARASITE EN CONTACT PONCTUEL AU PT DE
  645. C CONTACT ENTRE 2 "VRAIS" VOISINS
  646. C
  647. C IF(IPSTAR.EQ.IPFIN)THEN
  648. C NCYCLE(2,JE1)=-NCYCLE(2,JE1)
  649. C GOTO 105
  650. C ENDIF
  651. C
  652. C 5) ON AJOUTE LES POINTS (EN PARTANT DE LA FIN)
  653. C
  654. WORK1=TWORK(ICOURA)
  655. NPTO1=WORK1.XYC(/2)
  656. NPTO2=IPFIN-IPSTAR
  657. IF(NPTO2.LT.0)NPTO2=NPTO2+NPTO1
  658. NPTO=NPTO+NPTO2
  659. SEGADJ,WORK
  660. IPCOUR=IPFIN
  661. DO JE2=1,NPTO2
  662. IPCOUR=IPCOUR-1+(1/IPCOUR)*NPTO1
  663. XYC(1,NPTO-JE2+1)=WORK1.XYC(1,IPCOUR)
  664. XYC(2,NPTO-JE2+1)=WORK1.XYC(2,IPCOUR)
  665. DENS(NPTO-JE2+1)=WORK1.DENS(IPCOUR)
  666. ENDDO
  667. 105 CONTINUE
  668.  
  669. C
  670. C 6) BOUCLE SUR LES TROU DANS L'AUTRE SENS
  671. C
  672. DO 106 JE1=ITROU,2,-1
  673. C
  674. C 7) LOCALISATION DES TROUS VOISINS ET DES PT DE CONTACTS
  675. C (ON ECHANGE LE ROLE DE IPFIN ET IPSTAR)
  676. C
  677. IPAREN=NCYCLE(1,JE1)
  678. ICOURA=NCYCLE(2,JE1)
  679. IF(ICOURA.LT.0)GOTO 106
  680. IF(JE1.EQ.ITROU)THEN
  681. IENFAN=NTROV
  682. ELSE
  683. IENFAN=ABS(NCYCLE(2,JE1+1))
  684. ENDIF
  685. IPSTAR=0
  686. IPFIN=0
  687. DO JE2=1,NCONNE(ICOURA)
  688. IF(CONNEC(2,JE2,ICOURA).EQ.IPAREN)
  689. 1 IPFIN=CONNEC(1,JE2,ICOURA)
  690. IF(CONNEC(2,JE2,ICOURA).EQ.IENFAN)
  691. 1 IPSTAR=CONNEC(1,JE2,ICOURA)
  692. ENDDO
  693. IF(IPSTAR*IPFIN.EQ.0)THEN
  694. IRAISO=11
  695. SEGSUP,WORK
  696. GOTO 9999
  697. ENDIF
  698. C
  699. C 8) ON AJOUTE LES POINTS (EN PARTANT DE LA FIN)
  700. C
  701. WORK1=TWORK(ICOURA)
  702. NPTO1=WORK1.XYC(/2)
  703. NPTO2=IPFIN-IPSTAR
  704. IF(NPTO2.LT.0)NPTO2=NPTO2+NPTO1
  705. NPTO=NPTO+NPTO2
  706. SEGADJ,WORK
  707. IPCOUR=IPFIN
  708. DO JE2=1,NPTO2
  709. IPCOUR=IPCOUR-1+(1/IPCOUR)*NPTO1
  710. XYC(1,NPTO-JE2+1)=WORK1.XYC(1,IPCOUR)
  711. XYC(2,NPTO-JE2+1)=WORK1.XYC(2,IPCOUR)
  712. DENS(NPTO-JE2+1)=WORK1.DENS(IPCOUR)
  713. ENDDO
  714. 106 CONTINUE
  715. C
  716. C 9) NOUVEAU CONTOUR DANS WORK2
  717. C
  718. WORK2=WORK
  719. C
  720. C 10) ON AJUSTE LES TROUS (ON SUPRIME CEUX QUI ONT EFFECTIVEMENT
  721. C COALESCE
  722. C
  723. DO JE1=1,ITROU
  724. ICOURA=NCYCLE(2,JE1)
  725. IF(ICOURA.GT.0)THEN
  726. WORK=TWORK(ICOURA)
  727. IF(WORK.NE.0)THEN
  728. SEGSUP,WORK
  729. TWORK(ICOURA)=0
  730. ENDIF
  731. ENDIF
  732. ENDDO
  733. C
  734. C COUPE: LA FACE "B" EST DANS WORK2 ET "A" DANS WWORK
  735. C
  736. C ON ORIENTE CORRECTEMENT B
  737. C ON CHERCHE LES CONNEXIONS
  738. C ON COUPE
  739. C ON NE S'OCCUPE QUE DE LA PARTIE EXTERIEURE A LA COUPE
  740. C
  741. 200 CONTINUE
  742. CALL J3ORIE(1,WORK2.XYC,WORK2.DENS,WORK2.XYC(/2),1,TOL,IRET)
  743. IF(IRET.NE.0)THEN
  744. IRAISO=20
  745. GOTO 9999
  746. ENDIF
  747. WORK1=FWORK
  748. CALL J3COTO(WORK2,WORK1,TOL,IRET)
  749. IF(IRET.NE.0)THEN
  750. IRAISO=21
  751. GOTO 9999
  752. ENDIF
  753. CALL J3COTO(WORK1,WORK2,TOL,IRET)
  754. IF(IRET.NE.0)THEN
  755. IRAISO=22
  756. GOTO 9999
  757. ENDIF
  758. CALL J3JUNC(WORK1,WORK2,TOL,IRET)
  759. IF(IRET.NE.0)THEN
  760. IRAISO=23
  761. GOTO 9999
  762. ENDIF
  763. CALL J3JUNC(WORK2,WORK1,TOL,IRET)
  764. IF(IRET.NE.0)THEN
  765. IRAISO=24
  766. GOTO 9999
  767. ENDIF
  768. FWORK=WORK1
  769. CALL J3COUP(WWORK,WORK2,VWDUMM,VWORK2,1,TOL,IRET)
  770. CALL J3DET1(VWDUMM)
  771. CALL J3HEAD(WWORK,VWORK2)
  772. C
  773. C ON AJOUTE LES NOUVELLES FACES ET ON FLINGUE l'ANCIENNE
  774. C
  775. NFACN=VWORK2.FWWORK(/1)
  776. IF(NFACN.EQ.0)THEN
  777. IRET=IRET+1
  778. IRAISO=25
  779. GOTO 9999
  780. ENDIF
  781. WORK=FWORK
  782. SEGSUP,WWORK,WORK
  783. FWWORK(IE2)=VWORK2.FWWORK(NFACN)
  784. NFACE=NFACF+NFACN-1
  785. SEGADJ,VWORK
  786. DO JE1=1,NFACN-1
  787. FWWORK(NFACF+JE1)=VWORK2.FWWORK(JE1)
  788. ENDDO
  789. C
  790. C ON FAIT LE MENAGE ET ON RERENTRE DANS LA BOUCLE JE2
  791. C
  792. SEGSUP,WCYCL,VWORK2
  793. IE2=IE2-1
  794. NFACF=NFACE
  795. GOTO 1000
  796. C
  797. C ON ENTRE DANS LE CAS DU CONTACT MULTI PONCTUEL ENTRE 2 TROUS JE1 ET JE2
  798. C
  799. 300 CONTINUE
  800. WORK1=TWORK(JE1)
  801. WORK2=TWORK(JE2)
  802. C
  803. C ON VERIFIE...
  804. C
  805. CALL J3COTO(WORK2,WORK1,TOL,IRET)
  806. IF(IRET.NE.0)THEN
  807. IRAISO=30
  808. GOTO 9999
  809. ENDIF
  810. CALL J3COTO(WORK1,WORK2,TOL,IRET)
  811. IF(IRET.NE.0)THEN
  812. IRAISO=31
  813. GOTO 9999
  814. ENDIF
  815. CALL J3JUNC(WORK1,WORK2,TOL,IRET)
  816. IF(IRET.NE.0)THEN
  817. IRAISO=32
  818. GOTO 9999
  819. ENDIF
  820. CALL J3JUNC(WORK2,WORK1,TOL,IRET)
  821. IF(IRET.NE.0)THEN
  822. IRAISO=33
  823. GOTO 9999
  824. ENDIF
  825. C
  826. C ON COHALESCE DANS VWORK2
  827. C
  828. CALL J3COAL(WORK1,WORK2,.FALSE.,VWORK2,NFACEA,TOL,IRET)
  829. IF(IRET.GT.0)THEN
  830. IRAISO=34
  831. GOTO 9999
  832. ELSE
  833. JUNC=WORK2.JUN
  834. IF(JUNC.NE.0)SEGSUP,JUNC
  835. SEGSUP,WORK2
  836. TWORK(JE1)=WORK1
  837. TWORK(JE2)=0
  838. ENDIF
  839. C
  840. C ON DISTRIBUE
  841. C
  842. IF(NFACEA.GT.0)THEN
  843. CALL J3HEAD(WWORK,VWORK2)
  844. CALL J3COAK(WWORK,VWORK2,TOL,IRET)
  845. ENDIF
  846. C
  847. C ON AJUSTE
  848. C
  849. CALL J3REDU(WWORK)
  850. C
  851. C ON AJOUTE LES NOUVELLES FACES
  852. C
  853. NFACN=VWORK2.FWWORK(/1)
  854. IF(NFACN.EQ.0)THEN
  855. IRET=IRET+1
  856. IRAISO=35
  857. GOTO 9999
  858. ENDIF
  859. NFACE=NFACF+NFACN
  860. SEGADJ,VWORK
  861. DO JE1=1,NFACN
  862. FWWORK(NFACF+JE1)=VWORK2.FWWORK(JE1)
  863. ENDDO
  864. C
  865. C ON FAIT LE MENAGE ET ON RERENTRE DANS LA BOUCLE JE2
  866. C
  867. SEGSUP,WCYCL,VWORK2
  868. IE2=IE2-1
  869. NFACF=NFACE
  870. GOTO 1000
  871. C
  872. C
  873. C FIN BOUCLE FACE
  874. C
  875. 1001 CONTINUE
  876. C
  877. C FIN BOUCLE BLOCK
  878. C
  879. ENDDO
  880. C
  881. RETURN
  882. C
  883. C CONFIGURATION IMPOSSIBLE
  884. C
  885. 9999 CONTINUE
  886. IRET=IRET+1
  887. SEGSUP,WCYCL
  888. WRITE(IOIMP,*)' J3SURE: CONFIGURATION IMPOSSIBLE NO.',IRAISO
  889. RETURN
  890. C
  891. END
  892.  
  893.  
  894.  

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