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

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