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

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