Sources Esope | Cast3M

kdme
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