Sources Esope | Cast3M

xdiamm
C XDIAMM    SOURCE    CHAT      05/01/13    04:13:22     5004
      SUBROUTINE XDIAMM(MELEME,DIAM)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
-INC CCREEL
-INC SMELEME
-INC SMCOORD
 
-INC PPARAM
-INC CCOPTIO
*      PARAMETER (XPETI2=XPETIT**2)
      XPETI2 = xpetit
*      DIAM2=XGRAND**2
      DIAM2 = xgrand
      SEGACT MELEME
      NBSOUS=LISOUS(/1)
      IF(NBSOUS.EQ.0)NBSOUS=1
      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)
         IF(NP.EQ.1) THEN
C           On ne veut pas d'objet de type %m1:8
            MOTERR(1:8)='POI1    '
            CALL ERREUR(39)
            RETURN
         ENDIF
         DO 10 K=1,NEL
 
C             CALCUL DU DIAMETRE MIN
 
            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
                  DIAM2=MIN(DIAM2,XM2)
 322           CONTINUE
 321        CONTINUE
C
*            IF(DIAM2.LT.XPETI2) WRITE(6,*)
*     $           'xdiamm.eso : un element est peut-etre degenere'
 10      CONTINUE
         IF(NBSOUS.NE.1)SEGDES IPT1
 1    CONTINUE
      SEGDES MELEME
      DIAM=SQRT(DIAM2)
      RETURN
      END