C CORIO3 SOURCE PV090527 26/04/30 21:15:22 12529 SUBROUTINE CORIO3(IPMAIL,NDDL,LRE,NBPGAU,IPMINT, &MELE,MFR,IVAMAT,IVACAR,NMATT,IPMATR,VROT,NUMLIS,IIPDPG) *---------------------------------------------------------------------* * __________________________________________________ * * | | * * | calcul de la matrice de couplage gyroscopique | * * |________________________________________________| * * * * 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) * * vrot vecteur vitesse de rotation * * * * sorties : * * ________ * * * * ipmatr pointeur sur la matrice de couplage gyroscopique * * 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(*) * MELEME=IPMAIL c* SEGACT,MELEME NBNN=NUM(/1) NBELEM=NUM(/2) * NV1=NMATT SEGINI,MVELCH * xMATRI=IPMATR c* SEGACT,xMATRI C* NLIGRP=LRE C* NLIGRD=LRE XDPGE=0.D0 YDPGE=0.D0 * NHRM=NIFOUR * MINTE=IPMINT c* SEGACT,MINTE 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, 21, 99, 21, 99, 21, 99, 21, 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 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 DO 1005 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 c boucle sur les points de gauss c ISDJC=0 DO 1004 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.) THEN INTERR(1)= IB CALL ERREUR(259) GOTO 9011 ENDIF DJAC=ABS(DJAC)*POIGAU(IGAU) MPTVAL=IVAMAT IF (IVAL(1).NE.0) THEN MELVAL=IVAL(1) 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 1004 CONTINUE C C+DC On bouscule la matrice de masse C IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN INTERR(1)=IB CALL ERREUR(195) GOTO 9011 ENDIF c c remplissage de xmatri c CALL MTOGYR(LRE,NDDL,REL,VROT,RE(1,1,ib)) C 1005 CONTINUE 9011 CONTINUE SEGSUP WRK1,WRK2 GOTO 510 C c_______________________________________________________________________ c c secteur de calcul pour les elements 2D en mode de Fourier c_______________________________________________________________________ c 21 CONTINUE DIM3=1.D0 NBNO=NBNN NBBB=NBNN SEGINI WRK1,WRK2 DO 2005 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 c boucle sur les points de gauss c ISDJC=0 DO 2004 IGAU=1,NBPGAU * CALL NMATST(IGAU,MELE,MFR,NBNN,LRE/2,IFOUR,NIFOUR,NDDL/2, 1 DIM3,XE,SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE) IF(DJAC.LT.0.) ISDJC=ISDJC+1 IF(DJAC.EQ.0.) THEN INTERR(1)= IB CALL ERREUR(259) GOTO 9021 ENDIF DJAC=ABS(DJAC)*POIGAU(IGAU) MPTVAL=IVAMAT IF (IVAL(1).NE.0) THEN MELVAL=IVAL(1) 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/2,NDDL/2,REL) C 2004 CONTINUE C IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN INTERR(1)=IB CALL ERREUR(195) GOTO 9021 ENDIF c c remplissage de xmatri c IF (NUMLIS.EQ.1) THEN CALL MTOGY2(LRE/2,NDDL/2,REL,VROT,RE(1,1,ib)) ELSE CALL MTOGYF(LRE/2,NDDL/2,REL,VROT,RE(1,1,ib)) ENDIF C 2005 CONTINUE 9021 CONTINUE SEGSUP WRK1,WRK2 GOTO 510 c_______________________________________________________________________ * 99 CONTINUE MOTERR(1:4)=NOMTP(MELE) MOTERR(5:12)='CORIO3' CALL ERREUR(86) * 510 CONTINUE SEGSUP,MVELCH RETURN END