Télécharger j3aret.eso

Retour à la liste

Numérotation des lignes :

  1. C J3ARET SOURCE CHAT 05/01/13 00:45:53 5004
  2. SUBROUTINE J3ARET(BLOCOM,TOL)
  3. C--------------------------------------------------------------------
  4. C
  5. C ADDITION DES POINTS SUR LES ARRETES
  6. C
  7. C PP /9/97
  8. C Pierre Pegon/JRC Ispra
  9. C--------------------------------------------------------------------
  10. IMPLICIT INTEGER(I-N)
  11. IMPLICIT REAL*8 (A-H,O-Z)
  12. C
  13. -INC CCOPTIO
  14. -INC SMELEME
  15. C
  16. SEGMENT BLOCOM
  17. INTEGER POINT(NPOINT)
  18. REAL*8 YCOOR(IDIM+1,NPOINT)
  19. INTEGER MAILL(MM1)
  20. ENDSEGMENT
  21. C
  22. DIMENSION V1(3),V2(3),VI(3)
  23. C
  24. IF(IDIM.EQ.2)THEN
  25. V1(3)=0.D0
  26. V2(3)=0.D0
  27. VI(3)=0.D0
  28. ENDIF
  29. C
  30. MM1=MAILL(/1)
  31. NPOINT=POINT(/1)
  32. TOL2=TOL**2
  33. C
  34. C ON BOUCLE SUR TOUS LES CONTOURS
  35. C
  36. NBSOUS=0
  37. NBREF=0
  38. NBNN=2
  39. DO IE1=1,MM1
  40. MELEME=MAILL(IE1)
  41. NBELEM=ICOLOR(/1)
  42. C
  43. C ... ET SUR TOUS LEURS COTES
  44. C (ON SIMULE "DO 3 IE2=1,NBELEM" AVEC IE2 ET NBELEM EVENTUELLEMENT CHANGES)
  45. C
  46. IE2=0
  47. 1 IE2=IE2+1
  48. IF(IE2.GT.NBELEM)GOTO 3
  49. C DO IE2=1,NBELEM
  50. D12=0.D0
  51. DO IE3=1,IDIM
  52. V1(IE3)=YCOOR(IE3,NUM(1,IE2))
  53. V2(IE3)=YCOOR(IE3,NUM(2,IE2))
  54. D12=D12+(V1(IE3)-V2(IE3))**2
  55. ENDDO
  56. C
  57. C ON BOUCLE SUR TOUS LES POINTS ...
  58. C
  59. DO 2 IE3=1,NPOINT
  60. DI1=0.D0
  61. DI2=0.D0
  62. DO IE4=1,IDIM
  63. VI(IE4)=YCOOR(IE4,POINT(IE3))
  64. DI1=DI1+(VI(IE4)-V1(IE4))**2
  65. DI2=DI2+(VI(IE4)-V2(IE4))**2
  66. ENDDO
  67. C
  68. C ... ON ELIMINE CEUX QUI SONT TROP LOIN ...
  69. C
  70. IF((DI1.GT.D12+TOL2).OR.(DI2.GT.D12+TOL2))GOTO 2
  71. C
  72. C ... ON ELIMINE CEUX QUI SONT TROP PRES ...
  73. C
  74. IF((DI1.LT.TOL2).OR.(DI2.LT.TOL2))GOTO 2
  75. C
  76. C ... CEUX QUI NE SONT PAS ENTRE ...
  77. C
  78. AAA=0.D0
  79. DO IE4=1,IDIM
  80. AAA=AAA+(VI(IE4)-V1(IE4))*(V2(IE4)-V1(IE4))
  81. ENDDO
  82. AAA=AAA/D12
  83. IF(AAA.LT.0.D0.OR.AAA.GT.1.D0)GOTO 2
  84. C
  85. C ... ET CEUX QUI SONT TROP LOIN DU SEGMENT
  86. C
  87. BBB=0.D0
  88. DO IE4=1,IDIM
  89. BBB=BBB+(VI(IE4)-V1(IE4)-AAA*(V2(IE4)-V1(IE4)))**2
  90. ENDDO
  91. IF(BBB.GT.TOL2)GOTO 2
  92. C
  93. C ON INCERE LES POINT RESTANT DANS LE MAILLAGE
  94. C WARNING: ON LE FAIT SANS DUPLICATION
  95. C
  96. NBELEM=NBELEM+1
  97. SEGADJ, MELEME
  98. ICOLOR(NBELEM)=ICOLOR(NBELEM-1)
  99. IF(IE2.LT.NBELEM)THEN
  100. DO IE4=NBELEM,IE2+1,-1
  101. NUM(1,IE4)=NUM(1,IE4-1)
  102. NUM(2,IE4)=NUM(2,IE4-1)
  103. ENDDO
  104. ENDIF
  105. NUM(2,IE2 )=POINT(IE3)
  106. NUM(1,IE2+1)=POINT(IE3)
  107.  
  108. C ... ET ON REPASSE PAR LE NOUVEAU SEGMENT EN SORTANT DE LA BOUCLE POINT
  109. C
  110. IE2=IE2-1
  111. GOTO 1
  112. C
  113. C FIN BOUCLE POINT
  114. C
  115. 2 CONTINUE
  116. C
  117. C FIN BOUCLE COTE
  118. C
  119. GOTO 1
  120. 3 CONTINUE
  121. C
  122. C FIN BOUCLE FACE
  123. C
  124. ENDDO
  125. C
  126. RETURN
  127. END
  128.  
  129.  
  130.  

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