C KDME SOURCE CB215821 20/11/25 13:30:59 10792 SUBROUTINE KDME IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) C************************************************************************* C C OBJET : Cree un CHAMPOINT CENTRE contenant le diametre max des C éléments du domaine C C SYNTAXE : CHPC = KDME OBJDOM ; C C OBJDOM : TABLE de SOUSTYPE DOMAINE C C************************************************************************* -INC CCREEL -INC PPARAM -INC CCOPTIO -INC SMELEME -INC SMCOORD -INC SMCHPOI * PARAMETER (XPETI2=XPETIT**2) PARAMETER (NTB=1) CHARACTER*8 LTAB(NTB),TYPE,TYPC DIMENSION KTAB(NTB) DATA LTAB/'DOMAINE '/ C*** XPETI2 = XPETIT NTO=NTB CALL LITABS(LTAB,KTAB,NTB,NTO,IRET) IF(IRET.EQ.0)RETURN MTABD=KTAB(1) TYPE=' ' CALL ACMO(MTABD,'CENTRE',TYPE,MELEMC) IF(TYPE.NE.'MAILLAGE')GO TO 90 NC=1 TYPE='CENTRE' CALL CRCHPT(TYPE,MELEMC,NC,MCHPOI) C In LICHT -> SEGACT MPOVAL*MOD CALL LICHT(MCHPOI,MPOVAL,TYPC,IGEOM) TYPE=' ' CALL ACMO(MTABD,'MAILLAGE',TYPE,MELEME) IF(TYPE.NE.'MAILLAGE')GO TO 90 SEGACT MELEME NBSOUS=LISOUS(/1) IF(NBSOUS.EQ.0)NBSOUS=1 NELT=0 DO 1 L=1,NBSOUS IF(NBSOUS.EQ.1)THEN IPT1=MELEME ELSE IPT1=LISOUS(L) SEGACT IPT1 ENDIF NP=IPT1.NUM(/1) NEL=IPT1.NUM(/2) DO 10 K=1,NEL NELT=NELT+1 C CALCUL DU DIAMETRE MAX XMA2=0.D0 DO 321 I=1,NP-1 IPI=IPT1.NUM(I,K) DO 322 J=I+1,NP IPJ=IPT1.NUM(J,K) XM2=0.D0 DO 323 N=1,IDIM XM2=XM2+(XCOOR((IPI-1)*(IDIM+1)+N) $ -XCOOR((IPJ-1)*(IDIM+1)+N))**2 323 CONTINUE XMA2=MAX(XMA2,XM2) 322 CONTINUE 321 CONTINUE C * IF(XMA2.LT.XPETI2) WRITE(6,*) * $ 'kdme.eso : un element est peut-etre degenere' VPOCHA(NELT,1)=SQRT(XMA2) 10 CONTINUE SEGDES IPT1 1 CONTINUE IF(NBSOUS.NE.1) SEGDES MELEME SEGDES MPOVAL C CALL ECROBJ('CHPOINT ',MCHPOI) RETURN 90 CONTINUE * WRITE(6,*)' Interruption anormale dans kdme.eso' RETURN 1001 FORMAT(20(1X,I5)) END