C GYRO3 SOURCE PV090527 26/04/30 21:15:37 12529 SUBROUTINE GYRO3(IPMAIL,LRE,LW,MELE,IVAMAT,NMATT,IVACAR, &NCARR,IVECT,ISOUS,NBPGAU,IPMINT,IPMIN2,NDDL,MATE,CMATE, &LHOOK,IPMATR,IIPDPG) *---------------------------------------------------------------------* * _________________________________________________ * * | | * * | calcul de la matrice de couplage gyroscopique | * * | Matrice classique dans le repere inertiel | * * |________________________________________________| * * * * poutre,timo,tuyau * * * *---------------------------------------------------------------------* * * * entrees : * * ________ * * * * ipmail pointeur sur un segment meleme * * lre nombre de ddl dans la matrice de masse * * lw dimension du tableau de travail de l'element * * mele numero de l'element fini * * ivamat pointeur sur un segment mptval pour le materiau * * nmatt nombre de composante de materiau (imat=1) * * ivacar pointeur sur un segment mptval pour les caracteri- * * stiques * * ncarr nombre de caracteristiques geometriques * * ivect flag indiquant si on a entree les axes locaux * * isous numero de la sous-zone * * nbpgau nombre de point d'integration pour la masse * * ipmint pointeur sur un segment minte * * ipmin1 pointeur sur un segment minte (aux noeuds) * * nddl nombre de degre de liberte /noeud * * mate numero du materiau * * cmate nom du materiau * * vrot vecteur vitesse de rotation * * * * sorties : * * ________ * * * * ipmatr pointeur sur la matrice d'amortissement * * 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 WRK3 REAL*8 DDHOOK(LHOOK,LHOOK) REAL*8 WORK(LW) ENDSEGMENT C SEGMENT WRK4 REAL*8 BPSS(3,3),XEL(3,NBBB) ENDSEGMENT C SEGMENT WRK6 REAL*8 RHOMAT(6,6) ENDSEGMENT C SEGMENT MVELCH REAL*8 VALMAT(NV1) ENDSEGMENT DIMENSION CRIGI(12),CMASS(12) CHARACTER*8 CMATE * MELEME=IPMAIL NBNN=NUM(/1) NBELEM=NUM(/2) * NV1=NMATT SEGINI,MVELCH * xMATRI=IPMATR LVAL = (LRE*(LRE+1))/2 NLIGRP=LRE NLIGRD=LRE * NHRM=NIFOUR * MINTE=IPMINT MINTE2=IPMIN2 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 GOTO(99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99, 199,99,99,99,99,99,27,99,27,99,99,99,99,99,99,99,99,99,99,99, 299,27,99,99,99,27,99,99,99,99,99,99,99,99,99,99,99,99,99,99, 399,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99, 499,99,99,27,99,99,99,99,99,99,99,99,99,99,99,99,99),MELE GOTO 99 C_______________________________________________________________________ C_______________________________________________________________________ C C ELEMENTS POUTRES C_______________________________________________________________________ C 27 CONTINUE C C CAS DES POUTRES - TUYAUX C NBBB=NBNN SEGINI WRK1,WRK3 * * cas du materiau section * NBGMAT = 0 NELMAT = 0 IF(CMATE.EQ.'SECTION') THEN MPTVAL=IVAMAT DO IM=1,NMATT MELVAL=IVAL(IM) IF(MELVAL.NE.0)THEN NBGMAT=MAX(NBGMAT,IELCHE(/1)) NELMAT=MAX(NELMAT,IELCHE(/2)) END IF END DO ENDIF C C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS C SEGACT,MCOORD DO 3027 IB=1,NBELEM C C ON CHERCHE LES COORDONNEES DE L ELEMENT IB C CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) C C CAS DES POUTRES C -------------- C ON STOCKE DES CARACTERISTIQUES GEOMETRIQUES ET MATERIELLES DANS WORK C 5029 CONTINUE C C ON CHERCHE LES CARACTERISTIQUES DE L ELEMENT IB ( GEOMETRIE ET MASSE C C NCARR1=NCARR CALL ZERO(WORK,NCARR1,1) DO 4029 IGAU=1,NBNN MPTVAL=IVACAR DO 6029 IC=1,NCARR1 MELVAL=IVAL(IC) IF (MELVAL.NE.0) THEN IBMN=MIN(IB,VELCHE(/2)) IGMN=MIN(IGAU,VELCHE(/1)) WORK(IC)=WORK(IC)+VELCHE(IGMN,IBMN) ELSE WORK(IC)=0.D0 ENDIF IF (IGAU.EQ.NBNN) WORK(IC)=WORK(IC)/NBNN 6029 CONTINUE 4029 CONTINUE C C C CAS DES POUTRES ET TUYAU C MPTVAL=IVAMAT MELVAL=IVAL(1) IF(CMATE.NE.'SECTION') THEN IBMN=MIN(IB,VELCHE(/2)) C WORK(11)=VELCHE(1,IBMN) C C CAS DES TUYAUX - ON CALCULE LES CARACTERISTIQUES DE LA POUTRE C -------------- EQUIVALENTE C IF(MELE.EQ.42) CALL TUYCAG(WORK,KERRE,1) ELSE * * cas formulation section * IBMN=MIN(IB,IELCHE(/2)) IPMODL=IELCHE(1,IBMN) MELVAL=IVAL(2) IBMN=MIN(IB,IELCHE(/2)) IPMAT=IELCHE(1,IBMN) IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)THEN CALL FRIGIE(IPMODL,IPMAT,CRIGI,CMASS) CALL DOGTIF(CMASS,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) ENDIF ENDIF C C ON CALCULE LA MATRICE DE COUPLAGE GYROSCOPIQUE C IF (MELE.EQ.84) THEN IF(CMATE.NE.'SECTION') THEN CALL TIMGYR(REL,LRE,WORK,XE,WORK(12),KERRE) ELSE CALL TIFGYR(REL,LRE,WORK,XE,WORK(12),LHOOK, & DDHOOK,KERRE) ENDIF ELSE CALL POUGYR(REL,LRE,WORK,XE,WORK(12),KERRE) ENDIF C IF(KERRE.EQ.0) GO TO 4027 INTERR(1)=ISOUS INTERR(2)=IB SEGSUP WRK1,WRK3,MVELCH CALL ERREUR(128) SEGSUP xMATRI GO TO 510 C 4027 CONTINUE * SEGINI XMATRI * IMATTT(IB)=XMATRI DO IIIA=1,LRE DO IIIB=1,LRE RE(IIIA,IIIB,ib)=REL(IIIA,IIIB) enddo enddo C 3027 CONTINUE SEGSUP WRK1,WRK3,MVELCH GO TO 510 C_______________________________________________________________________ * 99 CONTINUE MOTERR(1:4)=NOMTP(MELE) MOTERR(5:12)='GYRO2' CALL ERREUR(86) * 510 CONTINUE RETURN END