Télécharger la plaquette Cast3M


fr en

Télécharger ajoupo.eso

Retour à la liste

Numérotation des lignes : 

ajoupo

  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