Télécharger j3coak.eso

Retour à la liste

Numérotation des lignes :

  1. C J3COAK SOURCE CHAT 05/01/13 00:45:59 5004
  2. SUBROUTINE J3COAK(WWORK1,VWORK,TOL,IRET)
  3. C----------------------------------------------------
  4. C COALESCENCE DES TROUS A ET B (ramasse miette pour les trou)
  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 PP 6/97 12/98
  17. C Pierre Pegon/JRC Ispra
  18. C----------------------------------------------------
  19. IMPLICIT INTEGER(I-N)
  20. IMPLICIT REAL*8(A-H,O-Z)
  21. -INC CCOPTIO
  22. C
  23. SEGMENT WORK
  24. REAL*8 XYC(2,NPTO)
  25. INTEGER IST(3,NPTO)
  26. REAL*8 DENS(NPTO)
  27. INTEGER JUN
  28. ENDSEGMENT
  29. POINTEUR WORK1.WORK,WORK2.WORK
  30. C
  31. SEGMENT WWORK
  32. REAL*8 PORIG(3),VNORM(3),VI(3),VJ(3)
  33. INTEGER FWORK
  34. INTEGER TWORK(NTROU)
  35. ENDSEGMENT
  36. POINTEUR WWORK1.WWORK
  37. C
  38. SEGMENT VWORK
  39. INTEGER FWWORK(NFACE)
  40. ENDSEGMENT
  41. C
  42. LOGICAL LAINB,LAOUB,LAONB,LBINA,LBOUA,LBONA
  43. C
  44. NTROU1=WWORK1.TWORK(/1)
  45. NFACE=FWWORK(/1)
  46. C
  47. C ON BOUCLE SUR LES NOUVELLES FACES ET ON EN EXTRAIT WORK QUE L'ON
  48. C PLACE EN A (WORK1)
  49. C
  50. NFACE=FWWORK(/1)
  51. DO IE1=1,NFACE
  52. IFACE=NFACE-IE1+1
  53. WWORK=FWWORK(IFACE)
  54. NTROU=TWORK(/1)
  55. IF(NTROU.NE.0)THEN
  56. IRET=IRET+1
  57. WRITE(IOIMP,*)'J3COAK: LE NOMBRE DE TROUS DANS LES NOUVELLES'
  58. WRITE(IOIMP,*)' FACES DOIT ETRE NUL'
  59. RETURN
  60. ENDIF
  61. WORK1=FWORK
  62. C
  63. C ON BOUCLE SUR LES TROUS DE A QUE L"ON PLACE EN B (WORK2)
  64. C
  65. DO IE2=1,NTROU1
  66. WORK2=WWORK1.TWORK(IE2)
  67. C
  68. C SI LE TROU EST ENCORE ACTIF ON REGARDE S'IL EST STRICTEMENT CONTENU
  69. C DANS A (en 98 on adoucit au cas sur les bord!!!)
  70. C
  71. IF(WORK2.NE.0)THEN
  72. CPP???
  73. CALL J3COTO(WORK2,WORK1,TOL,IRET)
  74. CPP???
  75. CALL J3COTO(WORK1,WORK2,TOL,IRET)
  76. IF(IRET.NE.0)RETURN
  77. NPTO1=WORK1.XYC(/2)
  78. CALL J3TES1(WORK1.IST,NPTO1,LAINB,LAOUB,LAONB,NAONB)
  79. NPTO2=WORK2.XYC(/2)
  80. CALL J3TES1(WORK2.IST,NPTO2,LBINA,LBOUA,LBONA,NBONA)
  81. C pp98 IF(LBINA)THEN
  82. IF(.NOT.LBOUA)THEN
  83. C pp98 IF(LBONA)THEN
  84. C pp98 IRET=IRET+1
  85. C pp98 WRITE(IOIMP,*)'J3COAK: A NE PEUT PAS ETRE SUR B'
  86. C pp98 RETURN
  87. C
  88. C SI OUI, ON BOUGE LE TROU DANS LA NOUVELLE FACE
  89. C
  90. C pp98 ELSE
  91. NTROU=NTROU+1
  92. SEGADJ,WWORK
  93. TWORK(NTROU)=WORK2
  94. WWORK1.TWORK(IE2)=0
  95. C pp98 ENDIF
  96. ENDIF
  97. ENDIF
  98. ENDDO
  99. ENDDO
  100. C
  101. RETURN
  102. END
  103.  
  104.  
  105.  

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