Télécharger j3coto.eso

Retour à la liste

Numérotation des lignes :

  1. C J3COTO SOURCE CHAT 05/01/13 00:46:10 5004
  2. SUBROUTINE J3COTO(WORK1,WORK2,TOL,IRET)
  3. C----------------------------------------------------
  4. C RAPPORT ENTRE LE CONTOUR DE WORK1 AVEC CELUI DE WORK2
  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 PP 6/97
  13. C Pierre Pegon/JRC Ispra
  14. C----------------------------------------------------
  15. C
  16. IMPLICIT INTEGER(I-N)
  17. IMPLICIT REAL*8(A-H,O-Z)
  18.  
  19. -INC PPARAM
  20. -INC CCOPTIO
  21. SEGMENT WORK
  22. REAL*8 XYC(2,NPTO)
  23. INTEGER IST(3,NPTO)
  24. REAL*8 DENS(NPTO)
  25. INTEGER JUN
  26. ENDSEGMENT
  27. POINTEUR WORK1.WORK, WORK2.WORK
  28. C
  29. DIMENSION XY1(2),XY2(2),XY3(2),XY4(2),XY(2)
  30. C
  31. IRET=0
  32. C
  33. NPTO1=WORK1.XYC(/2)
  34. CALL J3ZERI(WORK1.IST,3,NPTO1)
  35. NPTO2=WORK2.XYC(/2)
  36. CALL J3ZERI(WORK2.IST,3,NPTO2)
  37. C
  38. C ON CHERCHE A SAVOIR SI LES POINTS DE XYC1 SONT CONFONDU
  39. C AVEC DES POINTS DE XYC2, OU SUR LES COTES DE XYC2, OU BIEN
  40. C DEDANS OU DEHORS DE XYC2
  41. C
  42. DO IE1=1,NPTO1
  43. DO IE2=1,2
  44. XY1(IE2)=WORK1.XYC(IE2,IE1)
  45. ENDDO
  46. C
  47. ICOD=0
  48. C
  49. CALL J3NOCO(XY1,WORK2.XYC,NPTO2,TOL,IE2)
  50. IF(IE2.NE.0)THEN
  51. ICOD=2
  52. CALL J3BOCO(WORK1,IE1,IE2,IRET)
  53. IE2=IE2-1+(1/IE2)*NPTO2
  54. CALL J3BOCO(WORK1,IE1,IE2,IRET)
  55. ENDIF
  56. C
  57. IF(ICOD.EQ.0)THEN
  58. CALL J3DESS(XY1,WORK2.XYC,NPTO2,TOL,IE2)
  59. IF(IE2.NE.0)THEN
  60. ICOD=1
  61. CALL J3BOCO(WORK1,IE1,IE2,IRET)
  62. ENDIF
  63. ENDIF
  64. C
  65. IF(ICOD.EQ.0)THEN
  66. CALL J3INEX(XY1,WORK2.XYC,NPTO2,TOL,ICOD,ISIGM,IRET)
  67. WORK1.IST(1,IE1)=ICOD
  68. ENDIF
  69. C
  70. IF(IRET.GT.0)THEN
  71. RETURN
  72. ENDIF
  73. ENDDO
  74. C
  75. C ON REGARDE MAINTENANT S'IL Y A DES POINTS DE XYC2 QUI SONT
  76. C SUR XYC1. IL FAUT AJOUTER CES POINTS
  77. C
  78. DO IE1=1,NPTO2
  79. DO IE2=1,2
  80. XY2(IE2)=WORK2.XYC(IE2,IE1)
  81. ENDDO
  82. CALL J3NOCO(XY2,WORK1.XYC,NPTO1,TOL,IE2)
  83. IF(IE2.EQ.0)THEN
  84. CALL J3DESS(XY2,WORK1.XYC,NPTO1,TOL,IE2)
  85. IF(IE2.NE.0)THEN
  86. NPTO1=NPTO1+1
  87. IE2=IE2+1
  88. DENS1=WORK2.DENS(IE1)
  89. CALL J3POIN(WORK1,NPTO1,IE2,XY2,DENS1)
  90. CALL J3BOCO(WORK1,IE2,IE1,IRET)
  91. I1=IE1-1+(1/IE1)*NPTO2
  92. CALL J3BOCO(WORK1,IE2, I1,IRET)
  93. ENDIF
  94. ENDIF
  95. ENDDO
  96. C
  97. C ON REGARDE MAINTENANT LES INTERSECTIONS DE XYC1 AVEC XYC2
  98. C ET ON AJOUTE LES POINTS D'INTERSECTION
  99. C
  100. IE1=0
  101. 1 IE1=IE1+1
  102. IF(IE1.GT.NPTO1)GOTO 3
  103. C
  104. I1=IE1
  105. I2=IE1+1-(IE1/NPTO1)*IE1
  106. C
  107. IB1=WORK1.IST(2,I1)
  108. IB2=WORK1.IST(3,I1)
  109. IB3=WORK1.IST(2,I2)
  110. IB4=WORK1.IST(3,I2)
  111. C
  112. DO IE2=1,2
  113. XY1(IE2)=WORK1.XYC(IE2,I1)
  114. XY2(IE2)=WORK1.XYC(IE2,I2)
  115. ENDDO
  116. C
  117. DO 2 IE2=1,NPTO2
  118. C
  119. C (ON ELIMINE LES COTES DE XYC2 DEJA COUPES PAR XYC1)
  120. C
  121. IB=MIN(ABS(IB1-IE2),ABS(IB2-IE2),ABS(IB3-IE2),ABS(IB4-IE2))
  122. IF(IB.EQ.0)GOTO 2
  123. C
  124. I3=IE2
  125. I4=IE2+1-(IE2/NPTO2)*IE2
  126. DO IE3=1,2
  127. XY3(IE3)=WORK2.XYC(IE3,I3)
  128. XY4(IE3)=WORK2.XYC(IE3,I4)
  129. ENDDO
  130. C
  131. CALL J3SINT(XY1,XY2,XY3,XY4,TOL,XLAM,XGAM,XY)
  132. C
  133. IF((XLAM.GT.0.D0).AND.(XLAM.LT.1.D0).AND.
  134. > (XGAM.GT.0.D0).AND.(XGAM.LT.1.D0))THEN
  135. NPTO1=NPTO1+1
  136. DENS1=XLAM*WORK1.DENS(I2)+(1-XLAM)*WORK1.DENS(I1)
  137. CALL J3POIN(WORK1,NPTO1,IE1+1,XY,DENS1)
  138. CALL J3BOCO(WORK1,IE1+1,IE2,IRET)
  139. IE1=IE1-1
  140. GOTO 1
  141. ENDIF
  142. 2 CONTINUE
  143. C
  144. GOTO 1
  145. 3 CONTINUE
  146. IF(IRET.GT.0)RETURN
  147. C
  148. C ON CHERCHE A SAVOIR SI LES POINTS DE XYC2 SONT CONFONDU
  149. C AVEC DES POINTS DE XYC1, OU SUR LES COTES DE XYC1, OU BIEN
  150. C DEDANS OU DEHORS DE XYC1
  151. C
  152. DO IE1=1,NPTO2
  153. DO IE2=1,2
  154. XY2(IE2)=WORK2.XYC(IE2,IE1)
  155. ENDDO
  156. C
  157. ICOD=0
  158. C
  159. CALL J3NOCO(XY2,WORK1.XYC,NPTO1,TOL,IE2)
  160. IF(IE2.NE.0)THEN
  161. ICOD=2
  162. CALL J3BOCO(WORK2,IE1,IE2,IRET)
  163. IE2=IE2-1+(1/IE2)*NPTO1
  164. CALL J3BOCO(WORK2,IE1,IE2,IRET)
  165. ENDIF
  166. C
  167. IF(ICOD.EQ.0)THEN
  168. CALL J3DESS(XY2,WORK1.XYC,NPTO1,TOL,IE2)
  169. IF(IE2.NE.0)THEN
  170. ICOD=1
  171. CALL J3BOCO(WORK2,IE1,IE2,IRET)
  172. ENDIF
  173. ENDIF
  174. C
  175. IF(ICOD.EQ.0)THEN
  176. CALL J3INEX(XY2,WORK1.XYC,NPTO1,TOL,ICOD,ISIGM,IRET)
  177. WORK2.IST(1,IE1)=ICOD
  178. ENDIF
  179. C
  180. IF(IRET.GT.0)THEN
  181. RETURN
  182. ENDIF
  183. ENDDO
  184. C
  185. IF (IIMPI.EQ.1789)THEN
  186. WRITE(IOIMP,*)'J3COTO'
  187. NPTO1=WORK1.XYC(/2)
  188. WRITE(IOIMP,*)'WORK1: NUM,X,Y,IST1,IST2,IST3,DENS ',WORK1
  189. DO IE1=1,NPTO1
  190. WRITE(IOIMP,*)IE1,WORK1.XYC(1,IE1),WORK1.XYC(2,IE1),
  191. > WORK1.IST(1,IE1),WORK1.IST(2,IE1),WORK1.IST(3,IE1),
  192. > WORK1.DENS(IE1)
  193. ENDDO
  194. NPTO2=WORK2.XYC(/2)
  195. WRITE(IOIMP,*)'WORK2: NUM,X,Y,IST1,IST2,IST3,DENS ',WORK2
  196. DO IE1=1,NPTO2
  197. WRITE(IOIMP,*)IE1,WORK2.XYC(1,IE1),WORK2.XYC(2,IE1),
  198. > WORK2.IST(1,IE1),WORK2.IST(2,IE1),WORK2.IST(3,IE1),
  199. > WORK2.DENS(IE1)
  200. ENDDO
  201. ENDIF
  202. C
  203. RETURN
  204. END
  205.  
  206.  
  207.  

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