Sources Esope | Cast3M

kcent3
C KCENT3    SOURCE    OF166741  25/02/21    21:17:43     12166          
      SUBROUTINE KCENT3(IPMAIL,NDDL,LRE,NBPGAU,IPMINT,
     &MELE,MFR,IVAMAT,IVACAR,NMATT,IPMATR,VROT,IIPDPG)
*---------------------------------------------------------------------*
*        _______________________________________________              *
*        |                                             |              *
*        |  calcul de la matrice de raideur centrifuge |              *
*        |_____________________________________________|              *
*                                                                     *
*        massif                                                       *
*                                                                     *
*---------------------------------------------------------------------*
*                                                                     *
*   entrees :                                                         *
*   ________                                                          *
*                                                                     *
*        ipmail   pointeur sur un segment  meleme                     *
*        nddl     nombre de degre de liberte /noeud                   *
*        lre      nombre de ddl dans la matrice de masse              *
*        nbpgau   nombre de point d'integration pour la masse         *
*        ipmint   pointeur sur un segment minte                       *
*        ipmin1   pointeur sur un segment minte (aux noeuds)          *
*        mele     numero de l'element fini                            *
*        mfr      numero de la formulation                            *                                    *
*        ivamat   pointeur sur un segment mptval pour le materiau ou  *
*                 pour une matrice de hooke                           *
*        ivacar   pointeur sur un segment mptval pour les             *
*                 caracteristiques                                    *
*        nmatt    nombre de composante de materiau (imat=1)           *
*        iprota   pointeur sur un point (vecteur vitesse de rotation) *
*                                                                     *
*   sorties :                                                         *
*   ________                                                          *
*                                                                     *
*        ipmatr   pointeur sur la matrice de masse de la sous-zone    *
*                                                                     *
*                         Didier COMBESCURE mars 2003                 *
*---------------------------------------------------------------------*
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
 
-INC PPARAM
-INC CCOPTIO
-INC CCHAMP
-INC CCREEL
 
-INC SMRIGID
-INC SMCHAML
-INC SMELEME
-INC SMCOORD
-INC SMINTE
-INC SMMODEL
 
-INC TMPTVAL
 
      SEGMENT WRK1
      REAL*8 REL(LRE,LRE),XE(3,NBBB)
      ENDSEGMENT
c
      SEGMENT WRK2
      REAL*8 SHPWRK(6,NBNO),BGENE(NDDL,LRE)
      ENDSEGMENT
c
      SEGMENT WRK5
      REAL*8 BLX(NDDL,LRE),BLY(NDDL,LRE),BLZ(NDDL,LRE)
      REAL*8 BLT(NDDL,LRE)
      ENDSEGMENT
c
      SEGMENT MVELCH
      REAL*8 VALMAT(NV1)
      ENDSEGMENT
 
      DIMENSION VROT(*)
      DIMENSION ROME(3,3)
C      ,RELB(LRE,LRE)
 
      MELEME=IPMAIL
      NBNN=NUM(/1)
      NBELEM=NUM(/2)
*
      NV1=NMATT
      SEGINI,MVELCH
*
      xMATRI=IPMATR
      LVAL  = (LRE*(LRE+1))/2
      NLIGRP=LRE
      NLIGRD=LRE
 
      XDPGE=0.D0
      YDPGE=0.D0
 
      NHRM=NIFOUR
*
      MINTE=IPMINT
*
*     Remplissage de ROME depuis VROT qui est constant dans tout le modele
      ROME(1,1) = (-1.D0)*((VROT(2)**2) + (VROT(3)**2))
      ROME(2,2) = (-1.D0)*((VROT(1)**2) + (VROT(3)**2))
      ROME(3,3) = (-1.D0)*((VROT(1)**2) + (VROT(2)**2))
      ROME(1,2) = VROT(1)*VROT(2)
      ROME(1,3) = VROT(1)*VROT(3)
      ROME(2,3) = VROT(2)*VROT(3)
      ROME(2,1) = ROME(1,2)
      ROME(3,1) = ROME(1,3)
      ROME(3,2) = ROME(2,3)
c_______________________________________________________________________
c
c     numero des etiquettes      :
c     etiquettes de 1 a 98 pour traitement specifique a l element
c     dans la zone specifique a chaque element commencant par :
c     5  continue
c     element 5   etiquettes 1005 2005 3005 4005   ...
c     44 continue
c     element 44  etiquettes 1044 2044 3044 4044   ...
c_______________________________________________________________________
c
*                 CABL SEG2 SEG3 TRI3 TRI4 TRI6 TRI7 QUA4 QUA5 QUA8 QUA9
            GOTO (  99,  99,  99,  11,  99,  11,  99,  11,  99,  11,  99
*                 RAC2 RAC3 CUB8 CU20 PRI6 PR15 LIA3 LIA4 LIA6 LIA8 MULT
     &           ,  99,  99,  11,  11,  11,  11,  99,  99,  99,  99,  99
*                 TET4 TE10 PYR5 PY13 COQ3  DKT POUT LISP FAC3 FAC4 FAC6
     &           ,  11,  11,  11,  11,  99,  99,  99,  99,  99,  99,  99
*                 FAC8 LTR3 LQU4 LCU8 LPR6 LTE4 LPY5 COQ8 TUYA TUFI COQ2
     &           ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
*                 POI1 BARR RACO LSU2 COQ4 LISM COF3 RES2 LSU3 LSU4 LICO
     &           ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
*                 COQ6 CVS2 CVS3 CVT3 CVT6 CVQ4 CVQ8 THP5 TH13 THP6 TH15
     &           ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
*                 THC8 TH20 ICT3 ICQ4 ICT6 ICQ8 ICC8 ICT4 ICP6 IC20 IC10
     &           ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
*                 IC15 TRIP QUAP CUBP TETP PRIP TIMO JOI2 JOI3 JOT3 JOI4
     &           ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
*                 JOI6 JOI8 LISC TRIH  DST LIC4 CERC TUYO LSE2 LITU HYT3
     &           ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
*                 HYQ4 HYT4 HYP6 HYC8 TRIS QUAS POIS FOR3 JOP3 JOP6 JOP8
     &           ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
*                 POL3 POL4 POL5 POL6 POL7 POL8 POL9 PO10 PO11 PO12 PO13
     &           ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
*                 PO14 BAR3 BAEX LIA2 QUAH CUBH ROT3 SEF2 TRF3 QUF4 CUF8
     &           ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
*                 PRF6 TEF4 PYF5 MSE3 MTR6 MQU9 MC27 MP18 MT10 MP14 SEF3
     &           ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
*                 TRF7 QUF9 CF27 PF21 TF15 PF19 SEG6 TR21 QU36 C216 P126
     &           ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
*                 TE56 PY91 TRH6
     &           ,  99,  99,  99),MELE
c_______________________________________________________________________
      GOTO 99
c_______________________________________________________________________
c
c     secteur de calcul pour les elements massifs
c_______________________________________________________________________
c
  11  CONTINUE
      DIM3=1.D0
      NBNO=NBNN
      NBBB=NBNN
      SEGINI WRK1,WRK2
      I195=0
      I259=0
      DO 3004  IB=1,NBELEM
c
c        on cherche  les coordonnees des noeuds de l element ib
c
          CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
          CALL ZERO (REL,LRE,LRE)
C          CALL ZERO (RELB,LRE,LRE)
c
c        boucle sur les points de gauss
c
          ISDJC=0
          DO 4004  IGAU=1,NBPGAU
*
              CALL NMATST(IGAU,MELE,MFR,NBNN,LRE,IFOUR,NIFOUR,NDDL,
     1        DIM3,XE,SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
              IF(DJAC.LT.0.) ISDJC=ISDJC+1
              IF(DJAC.EQ.0.) I259=IB
              DJAC=ABS(DJAC)*POIGAU(IGAU)
              MPTVAL=IVAMAT
              MELVAL=IVAL(1)
              IF (MELVAL.NE.0) THEN
                  IGMN=MIN(IGAU,VELCHE(/1))
                  IBMN=MIN(IB,VELCHE(/2))
                  VALMAT(1)=VELCHE(IGMN,IBMN)
              ELSE
                  VALMAT(1)=0.D0
              ENDIF
              DJAC=DJAC*VALMAT(1)
              CALL NTNST(BGENE,DJAC,LRE,NDDL,REL)
C
 4004     CONTINUE
C
          IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) I195=IB
*          SEGINI XMATRI
*          IMATTT(IB)=XMATRI
C
C     On bouscule la matrice de masse
C
c               CALL MTOKCE(LRE,NDDL,REL,VROT,RE(1,1,ib))
              CALL MTOKCE(LRE,NDDL,REL,ROME,RE(1,1,ib))
C              CALL REMPMT(REL,LRE,RE)
C
*          SEGDES XMATRI
 3004 CONTINUE
      IF(I195.NE.0) INTERR(1)=I195
      IF(I195.NE.0) CALL ERREUR(195)
      IF(I259.NE.0) INTERR(1)=I259
      IF(I259.NE.0) CALL ERREUR(259)
      SEGDES xMATRI
      SEGSUP WRK1,WRK2,MVELCH
      GOTO 510
C
c_______________________________________________________________________
*
   99 CONTINUE
      MOTERR(1:4)=NOMTP(MELE)
      MOTERR(5:12)='KCENT3'
      CALL ERREUR(86)
*
  510 CONTINUE
      RETURN
      END