1 : C BARYCE SOURCE FANDEUR 07/01/29 21:15:00 5626 2 : C CALCUL LE BARYCENTRE D'UN OBJET 3 : C 4 : SUBROUTINE BARYCE 5 : IMPLICIT INTEGER(I-N) 6 : IMPLICIT REAL*8(A-H,O-Z) 7 : -INC CCOPTIO 8 : -INC SMELEME 9 : -INC SMCOORD 10 : DIMENSION XGRAV(4) 10 : CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU) 11 : IF (IERR.NE.0) RETURN 12 : SEGACT,MCOORD 13 : IDIMP1=IDIM+1 14 : XGRAV(1)=0. 15 : XGRAV(2)=0. 16 : XGRAV(3)=0. 17 : XGRAV(4)=0. 18 : NPOIN=0 19 : SEGACT,MELEME 20 : IPT1=MELEME 21 : DO 2 IO=1,MAX(1,LISOUS(/1)) 22 : IF (LISOUS(/1).NE.0) THEN 23 : IPT1=LISOUS(IO) 24 : SEGACT IPT1 25 : ENDIF 26 : NPOIN=NPOIN+IPT1.NUM(/2)*IPT1.NUM(/1) 27 : DO 3 I=1,IPT1.NUM(/1) 28 : DO 3 J=1,IPT1.NUM(/2) 29 : IREF=IDIMP1*(IPT1.NUM(I,J)-1) 30 : DO 5 L=1,IDIMP1 31 : 5 XGRAV(L)=XGRAV(L)+XCOOR(IREF+L) 32 : 3 CONTINUE 33 : IF (LISOUS(/1).NE.0) SEGDES IPT1 34 : 2 CONTINUE 35 : SEGDES,MELEME 36 : C ON MET LE CENTRE DE GRAVITE DANS LA TABLE DES POINTS 37 : NBPTS=XCOOR(/1)/IDIMP1+1 38 : SEGADJ,MCOORD 39 : IREF=(NBPTS-1)*IDIMP1 40 : DO 11 I=1,IDIMP1 41 : XCOOR(IREF+I)=XGRAV(I)/NPOIN 42 : 11 CONTINUE 43 : KGRAV=XCOOR(/1)/IDIMP1 43 : CALL ECROBJ('POINT ',KGRAV) 44 : RETURN 45 : END 46 : 47 :
© Cast3M 2003 - All rights reserved.
Disclaimer