Esope source files

   1 : C AJOUPO    SOURCE    BP208322  12/09/20    21:15:03     7512           
   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 :