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

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