C AJOUPO SOURCE PV 20/03/24 21:15:22 10554 C SUBROUTINE AJOUPO(PT,IMELE,CRIT,IPT) C-------------------------------------------------------------- C C FONCTION : C Verifie l'existence d'un point (defini par ses coordonnees) C dans un meleme (comme ELIM) C et crée ce point s'il n'existe pas (comme ADJUPO) C C ENTREE : PT Tableau x,y,z C IMELE Pointeur vers MELEME (actif en entre et sortie) C SORTIE : IPT Numero du point retrouvé ou créé C C APPELE PAR : INTGEO C C CREATION : BP 2012/09/04 C C-------------------------------------------------------------- IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) DIMENSION PT(3) C -INC PPARAM -INC CCOPTIO -INC SMCOORD -INC CCGEOME -INC SMELEME SEGMENT IDEJVU(NVU) C fonction distance au carré G(A,B,C,D,E,F)=((A-D)*(A-D)+(B-E)*(B-E)+(C-F)*(C-F)) C-------------------------------------------------------------- C RECUP DONNEES PRELIMINAIRES IDIM1=IDIM+1 SEGACT MCOORD*MOD c segment pour ne traiter qu'une seule fois chaque point NVU=NBPTS SEGINI,IDEJVU c coordonnees du point XI1=PT(1) XI2=PT(2) XI3=PT(3) c critere**2 PREC2=CRIT*CRIT C-------------------------------------------------------------- C ON RECHERCHE LE POINT (idem ELIM) c maillage a verifier IPT1 = IMELE c segact,IPT1 NBSOUS = IPT1.LISOUS(/1) c dans le cas d un meleme complexe, c il faut boucler sur les differents type d elements DO ISOUS=1,max(1,NBSOUS) if (NBSOUS.ne.0) then MELEME=IPT1.LISOUS(isous) c segact,meleme else MELEME=IPT1 endif NBNN = NUM(/1) NBEL = NUM(/2) c boucle sur les noeuds du maillage DO 72 J=1,NBEL DO 72 I=1,NBNN ii=NUM(I,J) IF(ii.eq.0) GOTO 72 IF(IDEJVU(ii).ne.0) GOTO 72 IDEJVU(ii)=1 IREF=(ii*IDIM1)-IDIM XJ1=XCOOR(IREF) IF(IDIM.GE.2) XJ2=XCOOR(IREF+1) IF(IDIM.GE.3) XJ3=XCOOR(IREF+2) A=G(XI1,XI2,XI3,XJ1,XJ2,XJ3) c si le critere est vérifié, on quitte en donnant le numéro de noeud IF(A.LE.PREC2) THEN IPT=ii GOTO 900 ENDIF 72 CONTINUE ENDDO c si le critere n'est jamais vérifié, on quitte en créant ce nouveau point C-------------------------------------------------------------- C ON CREE LE POINT (idem ADJUPO) NBPTS=NBPTS+1 SEGADJ,MCOORD C IREF=NBPTS*(IDIM1)-IDIM XCOOR(IREF) =XI1 XCOOR(IREF+1)=XI2 IF(IDIM.GE.3)THEN XCOOR(IREF+2)=XI3 XCOOR(IREF+3)=DENSIT ELSE XCOOR(IREF+2)=DENSIT ENDIF C IPT=NBPTS C-------------------------------------------------------------- C FIN DU PROGRAMME 900 CONTINUE segsup,idejvu RETURN END