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

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