Télécharger ajoupo.eso

Retour à la liste

Numérotation des lignes :

  1. C AJOUPO SOURCE PV 20/03/24 21:15:22 10554
  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. c segment pour ne traiter qu'une seule fois chaque point
  40. NVU=NBPTS
  41. SEGINI,IDEJVU
  42. c coordonnees du point
  43. XI1=PT(1)
  44. XI2=PT(2)
  45. XI3=PT(3)
  46. c critere**2
  47. PREC2=CRIT*CRIT
  48.  
  49.  
  50. C--------------------------------------------------------------
  51. C ON RECHERCHE LE POINT (idem ELIM)
  52.  
  53. c maillage a verifier
  54. IPT1 = IMELE
  55. c segact,IPT1
  56.  
  57. NBSOUS = IPT1.LISOUS(/1)
  58. c dans le cas d un meleme complexe,
  59. c il faut boucler sur les differents type d elements
  60. DO ISOUS=1,max(1,NBSOUS)
  61.  
  62. if (NBSOUS.ne.0) then
  63. MELEME=IPT1.LISOUS(isous)
  64. c segact,meleme
  65. else
  66. MELEME=IPT1
  67. endif
  68. NBNN = NUM(/1)
  69. NBEL = NUM(/2)
  70.  
  71. c boucle sur les noeuds du maillage
  72. DO 72 J=1,NBEL
  73. DO 72 I=1,NBNN
  74. ii=NUM(I,J)
  75. IF(ii.eq.0) GOTO 72
  76. IF(IDEJVU(ii).ne.0) GOTO 72
  77. IDEJVU(ii)=1
  78. IREF=(ii*IDIM1)-IDIM
  79. XJ1=XCOOR(IREF)
  80. IF(IDIM.GE.2) XJ2=XCOOR(IREF+1)
  81. IF(IDIM.GE.3) XJ3=XCOOR(IREF+2)
  82. A=G(XI1,XI2,XI3,XJ1,XJ2,XJ3)
  83. c si le critere est vérifié, on quitte en donnant le numéro de noeud
  84. IF(A.LE.PREC2) THEN
  85. IPT=ii
  86. GOTO 900
  87. ENDIF
  88. 72 CONTINUE
  89.  
  90. ENDDO
  91.  
  92. c si le critere n'est jamais vérifié, on quitte en créant ce nouveau point
  93.  
  94. C--------------------------------------------------------------
  95. C ON CREE LE POINT (idem ADJUPO)
  96.  
  97. NBPTS=NBPTS+1
  98. SEGADJ,MCOORD
  99. C
  100. IREF=NBPTS*(IDIM1)-IDIM
  101. XCOOR(IREF) =XI1
  102. XCOOR(IREF+1)=XI2
  103. IF(IDIM.GE.3)THEN
  104. XCOOR(IREF+2)=XI3
  105. XCOOR(IREF+3)=DENSIT
  106. ELSE
  107. XCOOR(IREF+2)=DENSIT
  108. ENDIF
  109. C
  110. IPT=NBPTS
  111.  
  112.  
  113. C--------------------------------------------------------------
  114. C FIN DU PROGRAMME
  115. 900 CONTINUE
  116. segsup,idejvu
  117.  
  118. RETURN
  119.  
  120. END
  121.  
  122.  
  123.  
  124.  
  125.  
  126.  
  127.  

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