Télécharger baryce.eso

Retour à la liste

baryce
C BARYCE    SOURCE    GOUNAND   21/04/13    21:15:00     10956          
*
*---------------------------------------------------------------*
*  CALCUL LE BARYCENTRE D'UN OBJET MAILLAGE
*
*  Creation : ???
*  Modif : BP, 2016-12-13 : ajout de l'option 'ELEM'
*---------------------------------------------------------------*
*
      SUBROUTINE BARYCE
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
 
 
-INC PPARAM
-INC CCOPTIO
-INC SMELEME
-INC SMCOORD
 
      DIMENSION XGRAV(4)
      CHARACTER*4 MOELEM(1)
      DATA MOELEM/'ELEM'/
 
C======================================================================      
c     LECTURES, ACTIVATIONS ET INITIALISATIONS
C======================================================================   
 
      CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU)      
      IF (IERR.NE.0) RETURN
 
      SEGACT,MCOORD*mod
      IDIMP1=IDIM+1
 
      CALL LIRMOT(MOELEM,1,IELEM,0)
      IF (IELEM.EQ.1) GOTO 10
 
 
C======================================================================   
c     BARYcentre du maillage
C======================================================================      
 
      XGRAV(1)=0.D0
      XGRAV(2)=0.D0
      XGRAV(3)=0.D0
      XGRAV(4)=0.D0
      NPOIN=0
 
      SEGACT,MELEME      
      IPT1=MELEME
 
C     BOUCLE SUR LE(S) MAILLAGE(S) ELEMENTAIRES      
      DO 2 IO=1,MAX(1,LISOUS(/1))
        IF (LISOUS(/1).NE.0) THEN
         IPT1=LISOUS(IO)
         SEGACT IPT1
        ENDIF
 
        NPOIN=NPOIN+IPT1.NUM(/2)*IPT1.NUM(/1)
        DO 3 J=1,IPT1.NUM(/2)
        DO 3 I=1,IPT1.NUM(/1)
          IREF=IDIMP1*(IPT1.NUM(I,J)-1)
          DO 5 L=1,IDIMP1
   5      XGRAV(L)=XGRAV(L)+XCOOR(IREF+L)
   3    CONTINUE
 
        IF (LISOUS(/1).NE.0) SEGDES IPT1
   2  CONTINUE
 
      SEGDES,MELEME
 
C     ERREUR SI MAILLAGE VIDE
      IF (NPOIN.EQ.0) THEN
         MOTERR(1:8)='MAILLAGE'
         CALL ERREUR(1027)
         RETURN
      ENDIF
 
C     ON MET LE CENTRE DE GRAVITE DANS LA TABLE DES POINTS
      NBPTS=NBPTS+1
      SEGADJ,MCOORD
      IREF=(NBPTS-1)*IDIMP1
      DO 7 I=1,IDIMP1
      XCOOR(IREF+I)=XGRAV(I)/NPOIN
   7  CONTINUE
      KGRAV=nbpts
 
      CALL ECROBJ('POINT   ',KGRAV)
      RETURN
 
 
  10  CONTINUE
C======================================================================   
c     BARYcentre de chaque ELEMent du maillage
C======================================================================   
 
c     CREATION D'UN NOUVEAU MAILLAGE DE POI1
      NBNN   = 1
      NBELEM = 0
      NBSOUS = 0
      NBREF  = 0 
      SEGINI,IPT2
      IPT2.ITYPEL = 1
      J2     = 0
 
      SEGACT,MELEME      
      IPT1=MELEME
 
C     BOUCLE SUR LE(S) MAILLAGE(S) ELEMENTAIRES      
      DO 12 IO=1,MAX(1,LISOUS(/1))
        IF (LISOUS(/1).NE.0) THEN
         IPT1=LISOUS(IO)
         SEGACT IPT1
        ENDIF
 
        NBELEM = NBELEM + IPT1.NUM(/2)
        SEGADJ,IPT2
        NBPTSJ=NBPTS
        NBPTS=NBPTS + IPT1.NUM(/2)
        SEGADJ,MCOORD
 
        DO 13 J=1,IPT1.NUM(/2)
          XGRAV(1)=0.D0
          XGRAV(2)=0.D0
          XGRAV(3)=0.D0
          XGRAV(4)=0.D0
          DO 14 I=1,IPT1.NUM(/1)
            IREF=IDIMP1*(IPT1.NUM(I,J)-1)
            DO 15 L=1,IDIMP1
  15        XGRAV(L)=XGRAV(L)+XCOOR(IREF+L)
  14      CONTINUE
C         ON MET LE CENTRE DE GRAVITE DANS:
C         LE MAILLAGE IPT2 + LA TABLE DES POINTS XCOOR
          NBPTSJ=NBPTSJ+1
          J2=J2+1
          IPT2.NUM(1,J2)=NBPTSJ
          IPT2.ICOLOR(J2)=IPT1.ICOLOR(J)
          IREF=(NBPTSJ-1)*IDIMP1
          DO 17 I=1,IDIMP1
            XCOOR(IREF+I)=XGRAV(I)/IPT1.NUM(/1)
  17      CONTINUE
  13    CONTINUE
        IF (LISOUS(/1).NE.0) SEGDES IPT1
  12  CONTINUE
 
C     ERREUR SI MAILLAGE VIDE
      IF (NBELEM.EQ.0) THEN
         MOTERR(1:8)='MAILLAGE'
         CALL ERREUR(1027)
         RETURN
      ENDIF
 
      SEGDES,MELEME
      SEGDES,IPT2
      CALL ECROBJ('MAILLAGE',IPT2)
 
 
      RETURN
      END
 
 
 
 
 
 
 
 

© Cast3M 2003 - Tous droits réservés.
Mentions légales