Télécharger ajoupo.eso

Retour à la liste

Numérotation des lignes :

  1. C AJOUPO SOURCE BP208322 16/11/18 21:15:06 9177
  2. C
  3. SUBROUTINE AJOUPO(PT,IMELE,CRIT,IPT)
  4. C--------------------------------------------------------------
  5. C
  6. C FONCTION :
  7. C Verifie l'existence d'un point (defini par ses coordonnees)
  8. C dans un meleme (comme ELIM)
  9. C et crée ce point s'il n'existe pas (comme ADJUPO)
  10. C
  11. C ENTREE : PT Tableau x,y,z
  12. C IMELE Pointeur vers MELEME (actif en entre et sortie)
  13. C SORTIE : IPT Numero du point retrouvé ou créé
  14. C
  15. C APPELE PAR : INTGEO
  16. C
  17. C CREATION : BP 2012/09/04
  18. C
  19. C--------------------------------------------------------------
  20. IMPLICIT INTEGER(I-N)
  21. IMPLICIT REAL*8(A-H,O-Z)
  22. DIMENSION PT(3)
  23. C
  24. -INC CCOPTIO
  25. -INC SMCOORD
  26. -INC CCGEOME
  27. -INC SMELEME
  28.  
  29. SEGMENT IDEJVU(NVU)
  30.  
  31. C fonction distance au carré
  32. G(A,B,C,D,E,F)=((A-D)*(A-D)+(B-E)*(B-E)+(C-F)*(C-F))
  33.  
  34.  
  35. C--------------------------------------------------------------
  36. C RECUP DONNEES PRELIMINAIRES
  37. IDIM1=IDIM+1
  38. SEGACT MCOORD*MOD
  39. NBPTS=XCOOR(/1)/IDIM1
  40. c segment pour ne traiter qu'une seule fois chaque point
  41. NVU=NBPTS
  42. SEGINI,IDEJVU
  43. c coordonnees du point
  44. XI1=PT(1)
  45. XI2=PT(2)
  46. XI3=PT(3)
  47. c critere**2
  48. PREC2=CRIT*CRIT
  49.  
  50.  
  51. C--------------------------------------------------------------
  52. C ON RECHERCHE LE POINT (idem ELIM)
  53.  
  54. c maillage a verifier
  55. IPT1 = IMELE
  56. c segact,IPT1
  57.  
  58. NBSOUS = IPT1.LISOUS(/1)
  59. c dans le cas d un meleme complexe,
  60. c il faut boucler sur les differents type d elements
  61. DO ISOUS=1,max(1,NBSOUS)
  62.  
  63. if (NBSOUS.ne.0) then
  64. MELEME=IPT1.LISOUS(isous)
  65. c segact,meleme
  66. else
  67. MELEME=IPT1
  68. endif
  69. NBNN = NUM(/1)
  70. NBEL = NUM(/2)
  71.  
  72. c boucle sur les noeuds du maillage
  73. DO 72 J=1,NBEL
  74. DO 72 I=1,NBNN
  75. ii=NUM(I,J)
  76. IF(ii.eq.0) GOTO 72
  77. IF(IDEJVU(ii).ne.0) GOTO 72
  78. IDEJVU(ii)=1
  79. IREF=(ii*IDIM1)-IDIM
  80. XJ1=XCOOR(IREF)
  81. IF(IDIM.GE.2) XJ2=XCOOR(IREF+1)
  82. IF(IDIM.GE.3) XJ3=XCOOR(IREF+2)
  83. A=G(XI1,XI2,XI3,XJ1,XJ2,XJ3)
  84. c si le critere est vérifié, on quitte en donnant le numéro de noeud
  85. IF(A.LE.PREC2) THEN
  86. IPT=ii
  87. GOTO 900
  88. ENDIF
  89. 72 CONTINUE
  90.  
  91. ENDDO
  92.  
  93. c si le critere n'est jamais vérifié, on quitte en créant ce nouveau point
  94.  
  95. C--------------------------------------------------------------
  96. C ON CREE LE POINT (idem ADJUPO)
  97.  
  98. NBPTS=NBPTS+1
  99. SEGADJ,MCOORD
  100. C
  101. IREF=NBPTS*(IDIM1)-IDIM
  102. XCOOR(IREF) =XI1
  103. XCOOR(IREF+1)=XI2
  104. IF(IDIM.GE.3)THEN
  105. XCOOR(IREF+2)=XI3
  106. XCOOR(IREF+3)=DENSIT
  107. ELSE
  108. XCOOR(IREF+2)=DENSIT
  109. ENDIF
  110. C
  111. IPT=NBPTS
  112.  
  113.  
  114. C--------------------------------------------------------------
  115. C FIN DU PROGRAMME
  116. 900 CONTINUE
  117. segsup,idejvu
  118.  
  119. RETURN
  120.  
  121. END
  122.  
  123.  
  124.  
  125.  
  126.  
  127.  

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