Télécharger j3coup.eso

Retour à la liste

Numérotation des lignes :

  1. C J3COUP SOURCE CHAT 05/01/13 00:46:14 5004
  2. SUBROUTINE J3COUP(WWORK1,WORK2,VWORK1,VWORK2,IRED,TOL,IRET)
  3. C----------------------------------------------------
  4. C COUPURE DES FACES 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 IRED=0 EMPECHE LA REDISTRIBUTION DES TROUS
  17. C
  18. C PP 6/97,11/98
  19. C Pierre Pegon/JRC Ispra
  20. C----------------------------------------------------
  21. IMPLICIT INTEGER(I-N)
  22. IMPLICIT REAL*8(A-H,O-Z)
  23. -INC CCOPTIO
  24. C
  25. SEGMENT WORK
  26. REAL*8 XYC(2,NPTO)
  27. INTEGER IST(3,NPTO)
  28. REAL*8 DENS(NPTO)
  29. INTEGER JUN
  30. ENDSEGMENT
  31. POINTEUR WORK1.WORK,WORK2.WORK
  32. C
  33. SEGMENT WWORK
  34. REAL*8 PORIG(3),VNORM(3),VI(3),VJ(3)
  35. INTEGER FWORK
  36. INTEGER TWORK(NTROU)
  37. ENDSEGMENT
  38. SEGMENT WWORK1.WWORK
  39. C
  40. SEGMENT VWORK
  41. INTEGER FWWORK(NFACE)
  42. ENDSEGMENT
  43. SEGMENT VWORK1.VWORK,VWORK2.VWORK
  44. C
  45. SEGMENT JUNC
  46. INTEGER CRO(2,NPTO)
  47. ENDSEGMENT
  48. SEGMENT JUNC1.JUNC,JUNC2.JUNC
  49. C
  50. LOGICAL LAINB,LAOUB,LAONB
  51. C
  52. IF (IIMPI.EQ.1789)THEN
  53. WRITE(IOIMP,*)'>>> On entre dans j3coup <<<'
  54. ENDIF
  55. C
  56. WORK1=WWORK1.FWORK
  57. C
  58. C ON CHERCHE LE NB D'INTERSECTION AVEC B
  59. C
  60. NPTO1=WORK1.XYC(/2)
  61. JUNC1=WORK1.JUN
  62. NPTO2=WORK2.XYC(/2)
  63. JUNC2=WORK2.JUN
  64. C
  65. NINTER=0
  66. DO IE1=1,NPTO1
  67. ISU=WORK1.IST(1,IE1)
  68. IF(ISU.GT.0)THEN
  69. CALL J3NUMP(WORK1.IST(1,IE1),NPTO2,I2)
  70. ICRO2=JUNC2.CRO(1,I2)
  71. ICRP2=JUNC2.CRO(2,I2)
  72. IF((ICRO2.EQ.-1).OR.(ICRP2.EQ.-1))THEN
  73. NINTER=NINTER+1
  74. IF(ICRO2+ICRP2.EQ.-2)THEN
  75. NINTER=NINTER+1
  76. ENDIF
  77. ENDIF
  78. ENDIF
  79. ENDDO
  80. C
  81. C NINTER DOIT ETRE UN MULTIPLE DE 2
  82. C
  83. NFAC1=NINTER/2
  84. IF(NINTER-2*NFAC1.NE.0)THEN
  85. IRET=IRET+1
  86. WRITE(IOIMP,*)'J3COUP: LE NOMBRE D"INTERSECTIONS DOIT ETRE PAIR'
  87. RETURN
  88. ENDIF
  89. NFAC1=NFAC1+1
  90. C
  91. C ON PREPARE QUI VA RECEVOIR LES FACES
  92. C
  93. NFACE=NFAC1
  94. SEGINI,VWORK1,VWORK2
  95. IFAC1=0
  96. IFAC2=0
  97. C
  98. C ON LOOP SUR LES FACES
  99. C
  100. IPLA1=1
  101. DO IE0=1,NFAC1
  102. C
  103. C ON CHERCHE LE DEBUT D'UNE INTERSECTION AVEC B
  104. C
  105. DO IE1=IPLA1,NPTO1
  106. ISU=WORK1.IST(1,IE1)
  107. IF(ISU.GT.0)THEN
  108. CALL J3NUMP(WORK1.IST(1,IE1),NPTO2,I2)
  109. ICRO2=JUNC2.CRO(1,I2)
  110. ICRP2=JUNC2.CRO(2,I2)
  111. IF((ICRO2.EQ.-1).OR.(ICRP2.EQ.-1))THEN
  112. GOTO 1
  113. ENDIF
  114. ENDIF
  115. ENDDO
  116. C >>>>>>>>>>>>> A VOIR SI IL NE FAUT PAS ALORS METTRE B!
  117. IF(IE0.EQ.NFAC1)GOTO 5
  118. IRET=IRET+1
  119. WRITE(IOIMP,*)'J3COUP: LE NOMBRE DE BLOCKS N"EST PAS ATTEINT'
  120. RETURN
  121. C >>>>>>>>>>>>> A VOIR SI IL NE FAUT PAS ALORS METTRE B!
  122. C
  123. C ON FORME UN NOUVEAU BLOCK EN CIRCULANT SUR B ET A TJS VERS
  124. C L'INTERIEUR, EN INVALIDANT LES INTERSECTION DE A AU FUR ET A
  125. C MESURE QUE ON LES RENCONTRE, ET JUSQU'A FERMETURE
  126. C
  127. C A) ON STOCKE LE PREMIER POINT DE LA NOUVELLE FACE ...
  128. C
  129. 1 CONTINUE
  130. IPLA1=IE1
  131. I1=IPLA1
  132. C
  133. NPTO=NPTO1+NPTO2
  134. SEGINI,WORK
  135. JUN=0
  136. IPTO=1
  137. DO IE2=1,2
  138. XYC(IE2,IPTO)=WORK1.XYC(IE2,IPLA1)
  139. ENDDO
  140. DENS(IPTO)=WORK1.DENS(IPLA1)
  141. C
  142. C B) ... PUIS ON L'INVALIDE
  143. C (PT DE BRANCHEMENT EN CAS DE PARCOURS MULTIPLE)
  144. C
  145. 2 CONTINUE
  146. WORK1.IST(1,I1)=0
  147. C
  148. C C) ON INITIALISE ENSUITE LE PARCOURS SUR B
  149. C "SENS DE LA NUMEROTATION" +1 ou -1 ?
  150. C FACILE SAUF EN CAS D'INTER MULTIPLE
  151. C
  152. IF(ICRO2+ICRP2.EQ.-2)THEN
  153. CALL J3ANG1(WORK1.XYC,NPTO1,I1,WORK2.XYC,NPTO2,I2,TOL,AG1,AG2)
  154. IF(ABS(AG1).LT.ABS(AG2))THEN
  155. ISEN2=-1
  156. ELSE
  157. ISEN2=+1
  158. ENDIF
  159. ELSE
  160. IF(ICRO2.EQ.-1)THEN
  161. ISEN2=-1
  162. ELSE
  163. ISEN2=+1
  164. ENDIF
  165. ENDIF
  166. C
  167. C D) ON RESTE SUR B JUSQU'AU CONTACT AVEC A
  168. C ON REVIENT ALORS SUR A SAUF SI IL Y A 2 COTE INTERIEUR ET QUE
  169. C ON LE PARCOURT DANS LE SENS + (DEDANS!)
  170. C
  171. DO IE2=1,NPTO2
  172. I2=I2+ISEN2
  173. IF((I2.LT.1).OR.(I2.GT.NPTO2))I2=I2-ISEN2*NPTO2
  174. C
  175. IPTO=IPTO+1
  176. DO IE3=1,2
  177. XYC(IE3,IPTO)=WORK2.XYC(IE3,I2)
  178. ENDDO
  179. DENS(IPTO)=WORK2.DENS(I2)
  180. C
  181. ISU=WORK2.IST(1,I2)
  182. IF(ISU.GT.0)THEN
  183. ICRO2=JUNC2.CRO(1,I2)
  184. ICRP2=JUNC2.CRO(2,I2)
  185. IF((ISEN2.EQ.-1).OR.(ICRO2.NE.-1).OR.(ICRP2.NE.-1))GOTO 3
  186. ENDIF
  187. C
  188. ENDDO
  189. C
  190. IRET=IRET+1
  191. WRITE(IOIMP,*)'J3COUP: ON NE PEUT PAS CIRCULER TJS SUR B!'
  192. RETURN
  193. C
  194. 3 CONTINUE
  195. C
  196. C E) ON INITIALISE LE PARCOURS SUR A (LE SENS DE PARCOURS EST TJ +1!)
  197. C
  198. CALL J3NUMP(WORK2.IST(1,I2),NPTO1,I1)
  199. DO IE2=1,NPTO1
  200. C
  201. I1=I1+1
  202. IF(I1.GT.NPTO1)I1=I1-NPTO1
  203. IF(I1.EQ.IPLA1)GOTO 4
  204. C
  205. IPTO=IPTO+1
  206. DO IE3=1,2
  207. XYC(IE3,IPTO)=WORK1.XYC(IE3,I1)
  208. ENDDO
  209. DENS(IPTO)=WORK1.DENS(I1)
  210. C
  211. ISU=WORK1.IST(1,I1)
  212. IF(ISU.GT.0)THEN
  213. CALL J3NUMP(WORK1.IST(1,I1),NPTO2,I2)
  214. ICRO2=JUNC2.CRO(1,I2)
  215. ICRP2=JUNC2.CRO(2,I2)
  216. IF((ICRO2.EQ.-1).OR.(ICRP2.EQ.-1))THEN
  217. GOTO 2
  218. ENDIF
  219. ENDIF
  220. C
  221. ENDDO
  222. C
  223. IRET=IRET+1
  224. WRITE(IOIMP,*)'J3COUP: ON NE PEUT PAS CIRCULER TJS SUR A!'
  225. RETURN
  226. C
  227. C F) LA FACE WORK EST FINIE, ON LA STOCKE SOIT DANS VWORK1 (FACES
  228. C INTERIEURES A B) SOIT DANS VWORK2 (FACES EXTERIEURES A B)
  229. C WARNING: SI LA FACE INTE A B EST EGALE A B, ON LA
  230. C REND IDENTIQUE A B
  231. C
  232. 4 CONTINUE
  233. C
  234. NPTO=IPTO
  235. SEGADJ,WORK
  236. C
  237. NTROU=0
  238. SEGINI,WWORK
  239. IF (ISEN2.EQ.+1)THEN
  240. IFAC1=IFAC1+1
  241. VWORK1.FWWORK(IFAC1)=WWORK
  242. CALL J3IDEN(WORK,WORK2,TOL)
  243. ELSE
  244. IFAC2=IFAC2+1
  245. VWORK2.FWWORK(IFAC2)=WWORK
  246. ENDIF
  247. FWORK=WORK
  248. IF(IFAC1+IFAC2.EQ.NFAC1)GOTO 6
  249. C
  250. C FIN LOOP SUR LES FACES
  251. C
  252. ENDDO
  253. C
  254. C CAS OU B EST LA DERNIERE FACE (C'EST ALORS L'UNIQUE FACE INTE!)
  255. C
  256. 5 CONTINUE
  257. IF(IFAC1.NE.0)THEN
  258. IRET=IRET+1
  259. WRITE(IOIMP,*)'J3COUP: B NE PEUT ETRE QUE L"UNIQUE FACE INTE'
  260. RETURN
  261. ENDIF
  262. SEGINI,WORK=WORK2
  263. JUN=0
  264. NTROU=0
  265. SEGINI,WWORK
  266. FWORK=WORK
  267. IFAC1=IFAC1+1
  268. VWORK1.FWWORK(IFAC1)=WWORK
  269. C
  270. C ON AJUSTE VWORK1 ET VWORK2
  271. C
  272. 6 CONTINUE
  273. NFACE=IFAC1
  274. SEGADJ,VWORK1
  275. NFACE=IFAC2
  276. SEGADJ,VWORK2
  277. C
  278. C ON VA MAINTENANT DISTRIBUER LES TROU DE A (DANS LES FACES EXTE
  279. C A B (INHIBE SI IRED=0)
  280. C
  281. IF(IRED.EQ.0)RETURN
  282. C
  283. C A) Y-A-T'IL DES TROUS DANS A
  284. C
  285. NTROU1=WWORK1.TWORK(/1)
  286. IF(NTROU1.EQ.0)RETURN
  287. C
  288. C B) ON LOOP SUR LES TROUS DE A QUE L'ON PLACE DANS WORK1
  289. C
  290. DO 11 IE1=1,NTROU1
  291. WORK1=WWORK1.TWORK(IE1)
  292. IF(WORK1.EQ.0)GOTO 11
  293. C
  294. C C) ON LOOP SUR LES FACES DE VWORK2 QUE L'ON PLACE DANS WORK2
  295. C
  296. DO IE2=1,NFACE
  297. WWORK=VWORK2.FWWORK(IE2)
  298. WORK2=FWORK
  299. C
  300. C D) LE TROU WORK1 EST-IL DANS LA FACE WORK2 (TEST MINIMUM)?
  301. C
  302. CALL J3COTO(WORK1,WORK2,TOL,IRET)
  303. IF (IRET.GT.0)THEN
  304. RETURN
  305. ENDIF
  306. NPTO1=WORK1.XYC(/2)
  307. CALL J3TES1(WORK1.IST,NPTO1,LAINB,LAOUB,LAONB,NAONB)
  308. C
  309. C E) SI OUI, ON LE MET DANS LA FACE ET ON LE RETIRE DE A
  310. C
  311. C>>>>>>>>>>>> .NOT.LAINB EN PLUS ??????
  312. IF(.NOT.LAOUB)THEN
  313. NTROU=TWORK(/1)
  314. NTROU=NTROU+1
  315. SEGADJ,WWORK
  316. TWORK(NTROU)=WORK1
  317. WWORK1.TWORK(IE1)=0
  318. GOTO 10
  319. C
  320. ENDIF
  321. ENDDO
  322. 10 CONTINUE
  323. 11 CONTINUE
  324. C
  325. C F) ON VERIFIE QUE TOUS LES TROUS DE A ONT ETE DISTRIBUES
  326. C
  327. DO IE1=1,NTROU1
  328. IF(WWORK1.TWORK(IE1).NE.0)THEN
  329. IRET=IRET+1
  330. WRITE(IOIMP,*)'J3COUP: TOUS LES TROUS DE A AURAIENT DUS ETRE'
  331. WRITE(IOIMP,*)' DIDTRIBUES'
  332. RETURN
  333. ENDIF
  334. ENDDO
  335. C
  336. RETURN
  337. END
  338.  
  339.  
  340.  

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